diff --git a/.Rbuildignore b/.Rbuildignore index 55c2e741..1b29c38b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,5 @@ +^renv$ +^renv\.lock$ ^.*\.Rproj$ ^\.Rproj\.user$ ^do-not-share$ diff --git a/.Rprofile b/.Rprofile new file mode 100644 index 00000000..a4766fdb --- /dev/null +++ b/.Rprofile @@ -0,0 +1,5 @@ +if(interactive()){ + library(devtools) + library(testthat) + library(vdiffr) +} diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 16be22f7..1447f7ec 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -1,115 +1,97 @@ +name: R-CMD-check + on: push: - branches: - - main - - master - - pre-release + branches: [main, master, pre-release] pull_request: - branches: - - main - - master - - pre-release - -name: R-CMD-check + branches: [main, master, pre-release] jobs: - R-CMD-check: + build: runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - strategy: fail-fast: false matrix: config: - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'release'} - # - {os: macOS-latest, r: 'release'} - # - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - # - {os: ubuntu-latest, r: 'oldrel-1'} - - env: - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_REMOTES_NO_ERRORS_FROM_WARNINGS: false - NOT_CRAN: true - + - {os: ubuntu-latest, r: 'release'} + - {os: macOS-latest, r: 'release'} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - - uses: r-lib/actions/setup-r@v2 + - name: Setup R + uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Query dependencies + # Install JAGS and system dependencies on Linux + - name: Install System Dependencies (Linux) + if: runner.os == 'Linux' run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - shell: Rscript {0} - - - name: Cache R packages - if: runner.os != 'Windows' - uses: actions/cache@v1 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-r-${{ matrix.config.r }}-3-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}-3- - - - name: Set path for RTools 4.0 - if: runner.os == 'Windows' - run: echo "C:/rtools40/usr/bin;C:/rtools40/mingw64/bin" | Out-File -Append -FilePath $env:GITHUB_PATH -Encoding utf8 - - - name: Install most Windows system dependencies + sudo apt-get update + sudo apt-get install -y \ + libssl-dev \ + libcurl4-openssl-dev \ + libxml2-dev \ + libfontconfig1-dev \ + libharfbuzz-dev \ + libfribidi-dev \ + libfreetype6-dev \ + libpng-dev \ + libtiff5-dev \ + libjpeg-dev \ + libcairo2-dev \ + jags + + # Install JAGS on Windows + - name: Install JAGS (Windows) if: runner.os == 'Windows' + shell: cmd run: | - pacman -Syu mingw-w64-x86_64-make --noconfirm - g++ --version - Get-Command g++ | Select-Object -ExpandProperty Definition - mingw32-make --version - Get-Command mingw32-make | Select-Object -ExpandProperty Definition - (New-Object System.Net.WebClient).DownloadFile('https://sourceforge.net/projects/mcmc-jags/files/JAGS/4.x/Windows/JAGS-4.3.1.exe', 'C:\JAGS-4.3.1.exe') - shell: powershell + curl -o jags-installer.exe -L https://sourceforge.net/projects/mcmc-jags/files/JAGS/4.x/Windows/JAGS-4.3.1.exe/download + jags-installer.exe /S + del jags-installer.exe - - name: Install JAGS on Windows + # Set JAGS environment variables on Windows + - name: Set JAGS environment variables (Windows) if: runner.os == 'Windows' - run: C:\JAGS-4.3.1.exe /S shell: cmd - - - name: Install Linux system dependencies - if: runner.os == 'Linux' - env: - RHUB_PLATFORM: linux-x86_64-ubuntu-gcc run: | - sudo apt-get install -y libglpk-dev - Rscript -e "remotes::install_github('r-hub/sysreqs')" - sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))") - sudo -s eval "$sysreqs" - sudo -s apt-get install jags - sudo -s apt-get install libv8-dev - sudo -s apt-get install libnode-dev - sudo -s apt-get install libcurl4-openssl-dev + echo JAGS_ROOT=C:\Program Files\JAGS\JAGS-4.3.1>> %GITHUB_ENV% + echo JAGS_MAJOR_VERSION=4>> %GITHUB_ENV% + echo PATH=C:\Program Files\JAGS\JAGS-4.3.1\bin;%PATH%>> %GITHUB_ENV% - - name: Install Mac system dependencies + # Install JAGS on macOS + - name: Install JAGS (macOS) if: runner.os == 'macOS' run: | - rm '/usr/local/bin/gfortran' - brew install automake jags - - - name: Install dependencies - if: runner.os != 'macOS' + brew update + brew install jags + + # Find and Set JAGS Paths + - name: Set Environment Variables (macOS) + if: runner.os == 'macOS' run: | - remotes::install_deps(dependencies = TRUE, type = ifelse(tolower(Sys.info()["sysname"]) == "linux", "source", "binary")) - remotes::install_cran("rcmdcheck") - shell: Rscript {0} + JAGS_BIN=$(brew --prefix jags)/bin + echo "JAGS_ROOT=$(brew --prefix jags)" >> $GITHUB_ENV + echo "PATH=$JAGS_BIN:$PATH" >> $GITHUB_ENV + echo "PKG_CONFIG_PATH=$(brew --prefix jags)/lib/pkgconfig" >> $GITHUB_ENV - - name: Install dependencies (macOS) + # Create Symlink for jags-terminal (if necessary) + - name: Create Symlink for jags-terminal (macOS) if: runner.os == 'macOS' run: | - remotes::install_deps(dependencies = TRUE, type = ifelse(tolower(Sys.info()["sysname"]) == "linux", "source", "binary")) - install.packages("rjags", type = "source") - remotes::install_cran("rcmdcheck") + sudo mkdir -p $(brew --prefix)/libexec + sudo ln -s $(brew --prefix jags)/bin/jags $(brew --prefix)/libexec/jags-terminal + + # Install the package + - name: Install the required packages + run: | + options(repos = c(CRAN = "https://cloud.r-project.org")) + install.packages('devtools') + install.packages('rcmdcheck') + install.packages(c('BayesFactor', 'RoBMA', 'runjags', 'rjags', 'rstan', 'scales', 'vdiffr', 'testthat', 'covr', 'pandoc')) + devtools::install() shell: Rscript {0} - name: Check @@ -117,6 +99,7 @@ jobs: env: _R_CHECK_CRAN_INCOMING_REMOTE_: false run: | + options(crayon.enabled = TRUE) rcmdcheck::rcmdcheck( args = c("--no-manual", "--as-cran", "--ignore-vignettes"), build_args = c("--no-build-vignettes"), @@ -131,16 +114,17 @@ jobs: JAGS_ROOT: "/c/progra~1/JAGS/JAGS-4.3.1" JAGS_MAJOR_VERSION: 4 run: | + options(crayon.enabled = TRUE) rcmdcheck::rcmdcheck( args = c("--no-manual", "--as-cran", "--ignore-vignettes"), build_args = c("--no-build-vignettes"), error_on = "warning", check_dir = "check") - shell: Rscript {0}" + shell: Rscript {0} - name: Upload check results if: failure() uses: actions/upload-artifact@main with: name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check \ No newline at end of file + path: check diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index b325007c..8b12586d 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -1,87 +1,64 @@ +name: pkgdown + on: push: branches: - main - master tags: - -'*' - -name: pkgdown + - '*' jobs: - pkgdown: + build: runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - strategy: fail-fast: false matrix: config: - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + - {os: windows-latest, r: 'release'} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - - uses: r-lib/actions/setup-r@v2 + - name: Setup R + uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Install harfbuzz freetype2 fribidi Headers - if: runner.os == 'Linux' - run: sudo apt-get install libharfbuzz-dev libfribidi-dev - - - - name: Query dependencies + # Install JAGS on Windows + - name: Install JAGS (Windows) + if: runner.os == 'Windows' + shell: cmd run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Restore R package cache - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- + curl -o jags-installer.exe -L https://sourceforge.net/projects/mcmc-jags/files/JAGS/4.x/Windows/JAGS-4.3.1.exe/download + jags-installer.exe /S + del jags-installer.exe - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - - name: Install JAGS (windows-latest) + # Set JAGS environment variables on Windows + - name: Set JAGS environment variables (Windows) if: runner.os == 'Windows' - run: | - curl.exe -o wjags.exe --url https://deac-fra.dl.sourceforge.net/project/mcmc-jags/JAGS/4.x/Windows/JAGS-4.3.1.exe - wjags.exe /S - del wjags.exe shell: cmd + run: | + echo JAGS_ROOT=C:\Program Files\JAGS\JAGS-4.3.1>> %GITHUB_ENV% + echo JAGS_MAJOR_VERSION=4>> %GITHUB_ENV% + echo PATH=C:\Program Files\JAGS\JAGS-4.3.1\bin;%PATH%>> %GITHUB_ENV% - - name: Install JAGS (macOS-latest) - if: runner.os == 'macOS' - run : | - rm '/usr/local/bin/gfortran' - brew install automake jags - - name: Install dependencies + # Install Pandoc + - name: Setup Pandoc + uses: r-lib/actions/setup-pandoc@v2 + + # Install the package and its dependencies + - name: Install required packages run: | - remotes::install_deps(dependencies = TRUE) - install.packages("pkgdown") + options(repos = c(CRAN = "https://cloud.r-project.org")) + install.packages('devtools') + install.packages('pkgdown') + install.packages(c('BayesFactor', 'RoBMA', 'runjags', 'rjags', 'rstan', 'scales', 'vdiffr', 'testthat', 'covr', 'pandoc')) + devtools::install() shell: Rscript {0} - - name: Install package - run: R CMD INSTALL . - - name: Deploy package run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' \ No newline at end of file + Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 96439566..ad2229e9 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,86 +1,57 @@ +name: test-coverage + on: push: - branches: - - main - - master - - pre-release + branches: [main, master, pre-release] pull_request: - branches: - - main - - master - - pre-release - -name: test-coverage + branches: [main, master, pre-release] jobs: - test-coverage: + build: runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - strategy: fail-fast: false matrix: config: - {os: windows-latest, r: 'release'} - #- {os: ubuntu-latest, r: 'release'} - #- {os: macOS-latest, r: 'release'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - - uses: r-lib/actions/setup-r@v2 + - name: Setup R + uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Restore R package cache - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install system dependencies - if: runner.os == 'Linux' + # Install JAGS on Windows + - name: Install JAGS (Windows) + if: runner.os == 'Windows' + shell: cmd run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') + curl -o jags-installer.exe -L https://sourceforge.net/projects/mcmc-jags/files/JAGS/4.x/Windows/JAGS-4.3.1.exe/download + jags-installer.exe /S + del jags-installer.exe - - name: Install JAGS (windows-latest) + # Set JAGS environment variables on Windows + - name: Set JAGS environment variables (Windows) if: runner.os == 'Windows' - run: | - curl.exe -o wjags.exe --url https://deac-fra.dl.sourceforge.net/project/mcmc-jags/JAGS/4.x/Windows/JAGS-4.3.1.exe - wjags.exe /S - del wjags.exe shell: cmd + run: | + echo JAGS_ROOT=C:\Program Files\JAGS\JAGS-4.3.1>> %GITHUB_ENV% + echo JAGS_MAJOR_VERSION=4>> %GITHUB_ENV% + echo PATH=C:\Program Files\JAGS\JAGS-4.3.1\bin;%PATH%>> %GITHUB_ENV% - - name: Install JAGS (macOS-latest) - if: runner.os == 'macOS' - run : | - rm '/usr/local/bin/gfortran' - brew install automake jags - - - name: Install dependencies + # Install the package + - name: Install the required packages run: | - install.packages(c("remotes")) - remotes::install_deps(dependencies = TRUE) - remotes::install_cran("covr") + options(repos = c(CRAN = "https://cloud.r-project.org")) + install.packages('devtools') + install.packages('rcmdcheck') + install.packages(c('BayesFactor', 'RoBMA', 'runjags', 'rjags', 'rstan', 'scales', 'vdiffr', 'testthat', 'covr', 'pandoc')) + devtools::install() shell: Rscript {0} + # Run the coverage check - name: Test coverage run: covr::codecov() - shell: Rscript {0} \ No newline at end of file + shell: Rscript {0} diff --git a/.gitignore b/.gitignore index 1f64b29e..f1f8ff58 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ .Rhistory .RData .Ruserdata +.Rprofile do-not-share docs BayesTools.Rcheck diff --git a/BayesTools.Rproj b/BayesTools.Rproj index 497f8bfc..cb843945 100644 --- a/BayesTools.Rproj +++ b/BayesTools.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 57fe60d0-34a8-40d6-b464-d3e8df30a8b0 RestoreWorkspace: Default SaveWorkspace: Default diff --git a/DESCRIPTION b/DESCRIPTION index 600396cd..52e9148b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: BayesTools Title: Tools for Bayesian Analyses -Version: 0.2.17 +Version: 0.2.18 Description: Provides tools for conducting Bayesian analyses and Bayesian model averaging (Kass and Raftery, 1995, , Hoeting et al., 1999, ). The package contains @@ -19,7 +19,7 @@ License: GPL-3 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.2 SystemRequirements: JAGS >= 4.3.0 (https://mcmc-jags.sourceforge.io/) Depends: stats @@ -43,6 +43,7 @@ Suggests: rjags, runjags, BayesFactor, + RoBMA, rmarkdown RdMacros: Rdpack VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index fc623770..49028dbb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,7 @@ S3method(range,prior) S3method(rng,prior) S3method(sd,default) S3method(sd,prior) +S3method(update,BayesTools_table) S3method(var,default) S3method(var,prior) export(JAGS_add_priors) @@ -51,6 +52,8 @@ export(JAGS_summary_table) export(JAGS_to_monitor) export(Savage_Dickey_BF) export(add_column) +export(as_marginal_inference) +export(as_mixed_posteriors) export(bridgesampling_object) export(ccdf) export(cdf) @@ -80,6 +83,7 @@ export(geom_prior) export(geom_prior_list) export(inclusion_BF) export(interpret) +export(interpret2) export(is.prior) export(is.prior.PEESE) export(is.prior.PET) @@ -87,6 +91,7 @@ export(is.prior.discrete) export(is.prior.factor) export(is.prior.independent) export(is.prior.meandif) +export(is.prior.mixture) export(is.prior.none) export(is.prior.orthonormal) export(is.prior.point) @@ -134,6 +139,7 @@ export(prior_PET) export(prior_factor) export(prior_informed) export(prior_informed_medicine_names) +export(prior_mixture) export(prior_none) export(prior_spike_and_slab) export(prior_weightfunction) diff --git a/NEWS.md b/NEWS.md index 6c2a77e6..c54e2c76 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,13 @@ +# version 0.2.18 +### Features +- adding `prior_mixture()` function for creating a mixture of prior distributions +- adding `as_mixed_posteriors()` and `as_marginal_inference()` functions for a single JAGS models (with spike and slab or mixture priors) to enabling tables and figures based on the corresponding output +- adding `interpret2()` function for another way of creating textual summaries without the need of inference and samples objects +- speedup and improvements to the `runjags_estimates_table()` function + +### Fixes +- small fixes for expansion of the RoBMA functionality + ## version 0.2.17 ### Features - adding informed prior distributions for dichotomous and time to event outcomes based on Cochrane Database of Systematic Reviews to `prior_informed()` function diff --git a/R/JAGS-diagnostics.R b/R/JAGS-diagnostics.R index 64daf8a9..3e08c52c 100644 --- a/R/JAGS-diagnostics.R +++ b/R/JAGS-diagnostics.R @@ -51,7 +51,7 @@ JAGS_diagnostics <- function(fit, parameter, type, plot_type = " check_list(prior_list, "prior_list") if(!all(sapply(prior_list, is.prior))) stop("'prior_list' must be a list of priors.") - check_char(parameter, "parameter", allow_values = names(prior_list)) + check_char(parameter, "parameter", allow_values = c(names(prior_list), if(any(names(prior_list) == "bias")) c("PET", "PEESE", "omega"))) if(!is.null(transformations)) check_char(names(transformations), "names(transformations)", allow_values = parameter) @@ -246,6 +246,8 @@ JAGS_diagnostics_autocorrelation <- function(fit, parameter, plot_type = "base", } }else if(is.prior.weightfunction(prior_list[[parameter]])){ model_samples <- model_samples[,paste0("omega", "[", (length(weightfunctions_mapping(list(prior_list[[parameter]]), cuts_only = TRUE)) - 2):1, "]"),drop = FALSE] + }else if(parameter == "omega" && !is.null(prior_list[["bias"]])){ + model_samples <- model_samples[,paste0("omega", "[", 2:(length(weightfunctions_mapping(prior_list[["bias"]][sapply(prior_list[["bias"]], is.prior.weightfunction)], cuts_only = TRUE, one_sided = TRUE)) - 1), "]"),drop = FALSE] }else if(is.prior.vector(prior_list[[parameter]])){ if(prior_list[[parameter]]$parameters[["K"]] > 1){ model_samples <- model_samples[,paste0(parameter, "[", 1:prior_list[[parameter]]$parameters[["K"]], "]"),drop = FALSE] @@ -261,8 +263,15 @@ JAGS_diagnostics_autocorrelation <- function(fit, parameter, plot_type = "base", model_samples <- model_samples[,parameter,drop = FALSE] } - prior_list <- prior_list[parameter] - parameter_names <- parameter + # deal with bias mixture dispatching + if(parameter %in% c("PET", "PEESE", "omega") && !is.null(prior_list[["bias"]])){ + prior_list <- prior_list[["bias"]] + parameter_names <- parameter + }else{ + prior_list <- prior_list[parameter] + parameter_names <- parameter + } + # mostly adapted from runjags_estimates_table # apply transformations @@ -342,7 +351,7 @@ JAGS_diagnostics_autocorrelation <- function(fit, parameter, plot_type = "base", } # rename weightfunctions factor levels - if(any(sapply(prior_list, is.prior.weightfunction))){ + if(any(sapply(prior_list, is.prior.weightfunction)) && !is.prior.mixture(prior_list)){ for(par in names(prior_list)[sapply(prior_list, is.prior.weightfunction)]){ omega_cuts <- weightfunctions_mapping(prior_list[par], cuts_only = TRUE) parameter_names <- sapply(1:(length(omega_cuts)-1), function(i)paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) @@ -350,12 +359,17 @@ JAGS_diagnostics_autocorrelation <- function(fit, parameter, plot_type = "base", } } + if(is.prior.mixture(prior_list) && parameter == "omega"){ + omega_cuts <- weightfunctions_mapping(prior_list[sapply(prior_list, is.prior.weightfunction)], cuts_only = TRUE, one_sided = TRUE) + parameter_names <- sapply(2:(length(omega_cuts)-1), function(i)paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) + } + # attach the relevant attributes colnames(model_samples) <- parameter_names attr(model_samples, "chain") <- do.call(c, samples_chain) attr(model_samples, "iter") <- do.call(c, samples_iter) attr(model_samples, "parameter") <- parameter - attr(model_samples, "prior") <- prior_list[[parameter]] + attr(model_samples, "prior") <- if(is.prior.mixture(prior_list)) prior_list else prior_list[[parameter]] return(model_samples) } diff --git a/R/JAGS-fit.R b/R/JAGS-fit.R index c07b575d..a248d99c 100644 --- a/R/JAGS-fit.R +++ b/R/JAGS-fit.R @@ -149,7 +149,7 @@ JAGS_fit <- function(model_syntax, data = NULL, prior_list = NULL, formula_list # parallel vs. not if(parallel){ cl <- parallel::makePSOCKcluster(cores) - on.exit(parallel::stopCluster(cl)) + on.exit(try(parallel::stopCluster(cl))) for(i in seq_along(required_packages)){ parallel::clusterCall(cl, function(x) requireNamespace(required_packages[i])) } @@ -198,9 +198,9 @@ JAGS_fit <- function(model_syntax, data = NULL, prior_list = NULL, formula_list if(inherits(fit, "error") & !silent) warning(paste0("The model estimation failed with the following error: ", fit$message), immediate. = TRUE) - if(autofit & !inherits(fit, "error")){ + if(autofit && !inherits(fit, "error")){ - converged <- JAGS_check_convergence(fit, prior_list, autofit_control[["max_Rhat"]], autofit_control[["min_ESS"]], autofit_control[["max_error"]], autofit_control[["max_SD_error"]]) + converged <- JAGS_check_convergence(fit, prior_list, autofit_control[["max_Rhat"]], autofit_control[["min_ESS"]], autofit_control[["max_error"]], autofit_control[["max_SD_error"]], fail_fast = TRUE) while(!converged){ @@ -222,13 +222,10 @@ JAGS_fit <- function(model_syntax, data = NULL, prior_list = NULL, formula_list break } - converged <- JAGS_check_convergence(fit, prior_list, autofit_control[["max_Rhat"]], autofit_control[["min_ESS"]], autofit_control[["max_error"]], autofit_control[["max_SD_error"]]) - } - } + fit <- runjags::add.summary(fit) - # stop cluster manually - if(parallel){ - parallel::stopCluster(cl) + converged <- JAGS_check_convergence(fit, prior_list, autofit_control[["max_Rhat"]], autofit_control[["min_ESS"]], autofit_control[["max_error"]], autofit_control[["max_SD_error"]], fail_fast = TRUE) + } } # add information to the fitted object @@ -260,7 +257,7 @@ JAGS_extend <- function(fit, autofit_control = list(max_Rhat = 1.05, min_ESS = 5 cores <- length(fit[["mcmc"]]) } cl <- parallel::makePSOCKcluster(cores) - on.exit(parallel::stopCluster(cl)) + on.exit(try(parallel::stopCluster(cl))) for(i in seq_along(required_packages)){ parallel::clusterCall(cl, function(x) requireNamespace(required_packages[i])) } @@ -295,9 +292,10 @@ JAGS_extend <- function(fit, autofit_control = list(max_Rhat = 1.05, min_ESS = 5 } start_time <- Sys.time() + itteration <- 0 converged <- FALSE - while(!converged){ + while(!converged & itteration < autofit_control[["restarts"]]){ if(!is.null(autofit_control[["max_time"]]) && difftime(Sys.time(), start_time, units = autofit_control[["max_time"]][["unit"]]) > autofit_control[["max_time"]][["time"]]){ if(!silent){ @@ -317,12 +315,13 @@ JAGS_extend <- function(fit, autofit_control = list(max_Rhat = 1.05, min_ESS = 5 break } - converged <- JAGS_check_convergence(fit, prior_list, autofit_control[["max_Rhat"]], autofit_control[["min_ESS"]], autofit_control[["max_error"]], autofit_control[["max_SD_error"]]) - } + converged <- JAGS_check_convergence(fit, prior_list, autofit_control[["max_Rhat"]], autofit_control[["min_ESS"]], autofit_control[["max_error"]], autofit_control[["max_SD_error"]], fail_fast = TRUE) - # stop cluster manually - if(parallel){ - parallel::stopCluster(cl) + # update the refit call + if(!converged){ + itteration <- itteration + 1 + refit_call$runjags.object <- fit + } } # add information to the fitted object @@ -349,6 +348,9 @@ JAGS_extend <- function(fit, autofit_control = list(max_Rhat = 1.05, min_ESS = 5 #' @param max_error maximum MCMC error. Defaults to \code{1.01}. #' @param max_SD_error maximum MCMC error as the proportion of standard #' deviation of the parameters. Defaults to \code{0.05}. +#' @param add_parameters vector of additional parameter names that should be used +#' (only allows removing last, fixed, omega element if omega is tracked manually). +#' @param fail_fast whether the function should stop after the first failed convergence check. #' #' @examples \dontrun{ #' # simulate data @@ -380,62 +382,118 @@ JAGS_extend <- function(fit, autofit_control = list(max_Rhat = 1.05, min_ESS = 5 #' #' @seealso [JAGS_fit()] #' @export -JAGS_check_convergence <- function(fit, prior_list, max_Rhat = 1.05, min_ESS = 500, max_error = 0.01, max_SD_error = 0.05){ +JAGS_check_convergence <- function(fit, prior_list, max_Rhat = 1.05, min_ESS = 500, max_error = 0.01, max_SD_error = 0.05, add_parameters = NULL, fail_fast = FALSE){ # check input if(!inherits(fit, "runjags")) stop("'fit' must be a runjags fit") - check_list(prior_list, "prior_list") - if(any(!sapply(prior_list, is.prior))) + check_list(prior_list, "prior_list", allow_NULL = TRUE) + if(!is.null(prior_list) && any(!sapply(prior_list, is.prior))) stop("'prior_list' must be a list of priors.") check_real(max_Rhat, "max_Rhat", lower = 1, allow_NULL = TRUE) check_real(min_ESS, "min_ESS", lower = 0, allow_NULL = TRUE) check_real(max_error, "max_error", lower = 0, allow_NULL = TRUE) check_real(max_SD_error, "max_SD_error", lower = 0, upper = 1, allow_NULL = TRUE) + check_char(add_parameters, "add_parameters", check_length = 0, allow_NULL = TRUE) - fails <- NULL - invisible(utils::capture.output(temp_summary <- suppressWarnings(summary(fit, silent.jags = TRUE)))) + # extract samples and parameter information + mcmc_samples <- coda::as.mcmc.list(fit) + parameter_names <- colnames(mcmc_samples[[1]]) + parameters_keep <- rep(TRUE, length(parameter_names)) # remove auxiliary and support parameters from the summary for(i in seq_along(prior_list)){ if(is.prior.weightfunction(prior_list[[i]])){ if(prior_list[[i]][["distribution"]] %in% c("one.sided", "two.sided")){ - temp_summary <- temp_summary[!grepl("eta", rownames(temp_summary)),,drop=FALSE] + parameters_keep[grepl("eta", parameter_names)] <- FALSE } - temp_summary <- temp_summary[-max(grep("omega", rownames(temp_summary))),,drop=FALSE] + parameter_names[max(grep("omega", parameter_names))] <- FALSE + }else if(is.prior.mixture(prior_list[[i]]) && any(sapply(prior_list[[i]], is.prior.weightfunction))){ + parameters_keep[max(grep("omega", parameter_names))] <- FALSE }else if(is.prior.point(prior_list[[i]])){ - temp_summary <- temp_summary[rownames(temp_summary) != names(prior_list)[i],,drop=FALSE] + parameters_keep[parameter_names == names(prior_list)[i]] <- FALSE }else if(is.prior.simple(prior_list[[i]]) && prior_list[[i]][["distribution"]] == "invgamma"){ - temp_summary <- temp_summary[rownames(temp_summary) != paste0("inv_",names(prior_list)[i]),,drop=FALSE] + parameters_keep[parameter_names == paste0("inv_",names(prior_list)[i])] <- FALSE + }else if(is.prior.mixture(prior_list[[i]]) && length(prior_list[[i]]) == 1 && is.prior.point(prior_list[[i]][[1]])){ + parameters_keep[parameter_names == names(prior_list)[i]] <- FALSE } } - # check the convergence + # remove indicators/inclusions + parameters_keep[grepl("_indicator", parameter_names)] <- FALSE + parameters_keep[grepl("_inclusion", parameter_names)] <- FALSE + + if(all(!parameters_keep)){ + return(TRUE) + } + + # remove parameters that are not monitored + for(i in seq_along(mcmc_samples)){ + mcmc_samples[[i]] <- mcmc_samples[[i]][,parameters_keep,drop=FALSE] + } + + ### check the convergence + fails <- NULL + + # assess R-hat if(!is.null(max_Rhat)){ - temp_Rhat <- max(ifelse(is.na(temp_summary[, "psrf"]), 1, temp_summary[, "psrf"])) - if(temp_Rhat > max_Rhat){ - fails <- c(fails, paste0("R-hat ", round(temp_Rhat, 3), " is larger than the set target (", max_Rhat, ").")) + if(length(fit$mcmc) == 1){ + warning("Only one chain was run. R-hat cannot be computed.", immediate. = TRUE) + }else{ + temp_Rhat <- coda::gelman.diag(mcmc_samples, multivariate = FALSE, autoburnin = FALSE)$psrf + temp_Rhat[is.na(temp_Rhat)] <- 1 + temp_Rhat <- max(temp_Rhat) + if(temp_Rhat > max_Rhat){ + fails <- c(fails, paste0("R-hat ", round(temp_Rhat, 3), " is larger than the set target (", max_Rhat, ").")) + if(fail_fast){ + return(FALSE) + } + } } } if(!is.null(min_ESS)){ - temp_ESS <- min(ifelse(is.na(temp_summary[, "SSeff"]), Inf, temp_summary[, "SSeff"])) + temp_ESS <- coda::effectiveSize(mcmc_samples) + temp_ESS[is.nan(temp_ESS) | temp_ESS == 0] <- Inf + temp_ESS <- min(temp_ESS) if(temp_ESS < min_ESS){ fails <- c(fails, paste0("ESS ", round(temp_ESS), " is lower than the set target (", min_ESS, ").")) + if(fail_fast){ + return(FALSE) + } } } + # compute the MCMC error and & SD error + if(!(is.null(max_error) && is.null(max_SD_error))){ + temp_summary <- summary(mcmc_samples, quantiles = NULL)$statistics + if(is.null(dim(temp_summary))){ + temp_summary <- t(temp_summary) + } + } + + if(!is.null(max_error)){ - temp_error <- max(ifelse(is.na(temp_summary[, "MCerr"]), 0, temp_summary[, "MCerr"])) + temp_error <- temp_summary[,"Time-series SE"] + temp_error[is.na(temp_error)] <- 0 + temp_error <- max(temp_error) if(temp_error > max_error){ fails <- c(fails, paste0("MCMC error ", round(temp_error, 5), " is larger than the set target (", max_error, ").")) + if(fail_fast){ + return(FALSE) + } } } if(!is.null(max_SD_error)){ - temp_error_SD <- max(ifelse(is.na(temp_summary[, "MC%ofSD"]), 0, temp_summary[, "MC%ofSD"])) - if(temp_error_SD/100 > max_SD_error){ - fails <- c(fails, paste0("MCMC SD error ", round(temp_error_SD/100, 4), " is larger than the set target (", max_SD_error, ").")) + temp_error_SD <- temp_summary[,"Time-series SE"] / temp_summary[,"SD"] + temp_error_SD[is.na(temp_error_SD)] <- 0 + temp_error_SD <- max(temp_error_SD) + if(temp_error_SD > max_SD_error){ + fails <- c(fails, paste0("MCMC SD error ", round(temp_error_SD, 3), " is larger than the set target (", max_SD_error, ").")) + if(fail_fast){ + return(FALSE) + } } } @@ -468,6 +526,8 @@ JAGS_add_priors <- function(syntax, prior_list){ stop("'prior_list' must be a list of priors.") .check_JAGS_syntax(syntax) + # create an empty attribute holder if any data need to be passed with the syntax + syntax_attributes <- NULL # identify parts of the syntax opening_bracket <- regexpr("{", syntax, fixed = TRUE)[1] @@ -476,9 +536,15 @@ JAGS_add_priors <- function(syntax, prior_list){ # create the priors relevant syntax syntax_priors <- .JAGS_add_priors.fun(prior_list) + if(!is.null(attr(syntax_priors, "auxiliary_data"))){ + syntax_attributes <- attr(syntax_priors, "auxiliary_data") + } # merge everything back together syntax <- paste0(syntax_start, "\n", syntax_priors, "\n", syntax_end) + if(!is.null(attr(syntax_priors, "auxiliary_data"))){ + attr(syntax, "auxiliary_data") <- syntax_attributes + } return(syntax) } @@ -486,6 +552,7 @@ JAGS_add_priors <- function(syntax, prior_list){ .JAGS_add_priors.fun <- function(prior_list){ syntax_priors <- "" + syntax_attributes <- NULL for(i in seq_along(prior_list)){ @@ -501,6 +568,14 @@ JAGS_add_priors <- function(syntax, prior_list){ syntax_priors <- paste(syntax_priors, .JAGS_prior.spike_and_slab(prior_list[[i]], names(prior_list)[i])) + }else if(is.prior.mixture(prior_list[[i]])){ + + syntax_mixture <- .JAGS_prior.mixture(prior_list[[i]], names(prior_list)[i]) + syntax_priors <- paste(syntax_priors, syntax_mixture) + if(!is.null(attr(syntax_mixture, "auxiliary_data"))){ + syntax_attributes <- attr(syntax_mixture, "auxiliary_data") + } + }else if(is.prior.factor(prior_list[[i]])){ syntax_priors <- paste(syntax_priors, .JAGS_prior.factor(prior_list[[i]], names(prior_list)[i])) @@ -516,6 +591,10 @@ JAGS_add_priors <- function(syntax, prior_list){ } } + if(length(syntax_attributes) > 0){ + attr(syntax_priors, "auxiliary_data") <- syntax_attributes + } + return(syntax_priors) } .JAGS_prior.simple <- function(prior, parameter_name){ @@ -730,12 +809,6 @@ JAGS_add_priors <- function(syntax, prior_list){ stop("improper prior provided") check_char(parameter_name, "parameter_name") - if(is.prior.PET(prior[["variable"]]) | is.prior.PEESE(prior[["variable"]]) | is.prior.weightfunction(prior[["variable"]])) - stop("Spike and slab functionality is not implemented for publication bias prior distributions.") - if(is.prior.spike_and_slab(prior[["variable"]])) - stop("Spike and slab prior distribution cannot be nested inside of a spike and slab prior distribution.") - - prior_variable_list <- prior["variable"] prior_inclusion_list <- prior["inclusion"] names(prior_variable_list) <- paste0(parameter_name, "_variable") @@ -750,7 +823,186 @@ JAGS_add_priors <- function(syntax, prior_list){ return(syntax) } +.JAGS_prior.mixture <- function(prior_list, parameter_name){ + + .check_prior_list(prior_list) + if(!is.prior.mixture(prior_list)) + stop("improper prior provided") + check_char(parameter_name, "parameter_name") + + if(inherits(prior_list, "prior.bias_mixture")){ + + # dispatch between publication bias prior mixture and a standard prior mixture + is_PET <- sapply(prior_list, is.prior.PET) + is_PEESE <- sapply(prior_list, is.prior.PEESE) + is_weightfunction <- sapply(prior_list, is.prior.weightfunction) + is_none <- sapply(prior_list, is.prior.none) + + prior_weights <- attr(prior_list, "prior_weights") + syntax <- paste0(" bias_indicator ~ dcat(c(", paste0(prior_weights, collapse = ", "), "))\n") + + # if any prior is bias related, the whole component must be dispatching publication bias + if(any(!(is_PET | is_PEESE | is_weightfunction | is_none))) + stop("Mixture of publication bias and standard priors is not supported.") + if(any(is_PET)){ + if(sum(is_PET) > 1) stop("Only one PET style publication bias adjustment is allowed.") + + named_prior_PET <- prior_list[[which(is_PET)]] + class(named_prior_PET) <- class(named_prior_PET)[!class(named_prior_PET) %in% "prior.PET"] + named_prior_PET <- list("PET_1" = named_prior_PET) + + syntax <- paste0( + syntax, + .JAGS_add_priors.fun(named_prior_PET), + " PET = PET_1 * (bias_indicator == ", which(is_PET), ")\n" + ) + } + if(any(is_PEESE)){ + if(sum(is_PEESE) > 1) stop("Only one PEESE style publication bias adjustment is allowed.") + + named_prior_PEESE <- prior_list[[which(is_PEESE)]] + class(named_prior_PEESE) <- class(named_prior_PEESE)[!class(named_prior_PEESE) %in% "prior.PEESE"] + named_prior_PEESE <- list("PEESE_1" = named_prior_PEESE) + + syntax <- paste0( + syntax, + .JAGS_add_priors.fun(named_prior_PEESE), + " PEESE = PEESE_1 * (bias_indicator == ", which(is_PEESE), ")\n" + ) + } + if(any(is_weightfunction)){ + # we cannot simulate weights from the mixture distribution directly because + # JAGS does not allow complex support for the cumulative simplex parameter + # (we could make it on the non-cumulative simplex but it does not give more advantage) + + # create a vector of the alpha parameters + alpha <- lapply(prior_list[is_weightfunction], function(x){ + if(grepl("fixed", x[["distribution"]])){ + return(x$parameters[["omega"]]) + }else{ + return(x$parameters[["alpha"]]) + } + }) + + # dispatch the prior distribution on weight parameters + syntax <- paste0( + syntax, + " for(i in 1:", max(lengths(alpha)), "){\n", + " eta[i] ~ dgamma(eta_shape[i, bias_indicator], 1)\n", + " }\n" + ) + + # transform etas into weights (eta2omega JAGS function is in the RoBMA package) + syntax <- paste0(syntax, " omega = eta2omega(eta, omega_index[,bias_indicator], eta_index[,bias_indicator], eta_index_max[bias_indicator])\n") + + # add the necessary auxiliary data: omega_index, eta_index, eta_index_max, eta_shape + # create the weightfunction mapping for weights + omega_index_weighfunction <- weightfunctions_mapping(prior_list[is_weightfunction], one_sided = TRUE) + omega_index_weighfunction <- lapply(omega_index_weighfunction, rev) + omega_index_weighfunction <- do.call(rbind, omega_index_weighfunction) + omega_index <- matrix(0, ncol = ncol(omega_index_weighfunction), length(prior_list)) + omega_index[is_weightfunction,] <- omega_index_weighfunction + + # in case of fixed weight functions, the omega_index direly corresponds to the fixed weights + for(i in seq_along(prior_list)){ + if(is.prior.weightfunction(prior_list[[i]])){ + if(grepl("fixed", prior_list[[i]]$distribution)){ + omega_index[i,] <- prior_list[[i]]$parameters[["omega"]][omega_index[i,]] + } + } + } + + # create the eta to omega mapping + # eta_index_max helps dispatching within the eta2omega function + # 0 = non-weightfunction, all weights are set to 0 + # >1 = indicates how many alpha parameters are needed to construct the weightfunction based on the eta_index + # -1 = indicates fixed weightfunction, omega index already encoded all weights + eta_index <- matrix(0, nrow = length(prior_list), ncol = max(lengths(alpha))) + eta_index_max <- rep(0, length(prior_list)) + for(i in seq_along(prior_list)){ + if(is.prior.weightfunction(prior_list[[i]])){ + if(grepl("fixed", prior_list[[i]]$distribution)){ + eta_index_max[i] <- -1 + eta_index[i,] <- -1 + }else{ + temp_index <- unique(omega_index[i,]) + eta_index[i,1:length(temp_index)] <- sort(temp_index) + eta_index_max[i] <- length(temp_index) + } + }else{ + eta_index_max[i] <- 0 + } + } + + # create priors for eta (set alpha to 1 for non-weightfunctions to keep the sampling in the expected area) + eta_shape <- matrix(1, nrow = length(prior_list), ncol = max(lengths(alpha))) + for(i in seq_along(prior_list)){ + if(is.prior.weightfunction(prior_list[[i]])){ + if(!grepl("fixed", prior_list[[i]]$distribution)){ + temp_shape <- prior_list[[i]]$parameters[["alpha"]] + eta_shape[i,1:length(temp_shape)] <- temp_shape + } + } + } + + # paste the matricies directly into JAGS code (simplifies data handling) + syntax <- paste0( + syntax, + .add_JAGS_matrix("omega_index", t(omega_index)), + .add_JAGS_matrix("eta_index", t(eta_index)), + .add_JAGS_vector("eta_index_max", eta_index_max), + .add_JAGS_matrix("eta_shape", t(eta_shape)) + ) + } + + }else{ + + prior_weights <- attr(prior_list, "prior_weights") + prior_components <- as.list(prior_list) + class(prior_components) <- "list" + names(prior_components) <- paste0(parameter_name, "_component_", seq_along(prior_components)) + + syntax <- paste0( + " ", parameter_name, "_indicator ~ dcat(c(", paste0(prior_weights, collapse = ", "), "))\n", + sapply(.JAGS_add_priors.fun(prior_components), paste, collapse = "\n"), + " ", parameter_name, " = ", paste0(names(prior_components), " * ", paste0("(", parameter_name, "_indicator == ", seq_along(prior_components), ")"), collapse = " + "), "\n" + ) + } + + return(syntax) +} + + +.add_JAGS_vector <- function(name, vector){ + + if(!is.vector(vector)) + stop("vector must be a vector") + check_char(name, "name") + + syntax <- paste0(" ", name, " = c(", paste0(vector, collapse = ", "), ")\n") + + return(syntax) +} +.add_JAGS_matrix <- function(name, matrix){ + + if(!is.matrix(matrix)) + stop("matrix must be a matrix") + check_char(name, "name") + + syntax <- "" + + # this unfortunatelly cannot be defined on row/column basis + # I tried simplifying this before but only possible initialization is elementwise + for(i in 1:nrow(matrix)){ + syntax <- paste0( + syntax, " ", + paste0(name,"[", i, ",", seq_len(ncol(matrix)), "] = ", matrix[i,], collapse = "; "), "\n" + ) + } + + return(syntax) +} .check_JAGS_syntax <- function(syntax){ check_char(syntax, "syntax", allow_NULL = TRUE) @@ -837,6 +1089,10 @@ JAGS_get_inits <- function(prior_list, chains, seed){ temp_inits <- c(temp_inits, .JAGS_init.spike_and_slab(prior_list[[i]], names(prior_list)[i])) + }else if(is.prior.mixture(prior_list[[i]])){ + + temp_inits <- c(temp_inits, .JAGS_init.mixture(prior_list[[i]], names(prior_list)[i])) + }else if(is.prior.factor(prior_list[[i]])){ temp_inits <- c(temp_inits, .JAGS_init.factor(prior_list[[i]], names(prior_list)[i])) @@ -993,6 +1249,74 @@ JAGS_get_inits <- function(prior_list, chains, seed){ return(init) } +.JAGS_init.mixture <- function(prior_list, parameter_name){ + + .check_prior_list(prior_list) + if(!is.prior.mixture(prior_list)) + stop("improper prior provided") + check_char(parameter_name, "parameter_name") + + if(inherits(prior_list, "prior.bias_mixture")){ + + # dispatch between publication bias prior mixture and a standard prior mixture + is_PET <- sapply(prior_list, is.prior.PET) + is_PEESE <- sapply(prior_list, is.prior.PEESE) + is_weightfunction <- sapply(prior_list, is.prior.weightfunction) + is_none <- sapply(prior_list, is.prior.none) + + init <- list() + + # if any prior is bias related, the whole component must be dispatching publication bias + if(any(!(is_PET | is_PEESE | is_weightfunction | is_none))) + stop("Mixture of publication bias and standard priors is not supported.") + + if(any(is_PET)){ + if(sum(is_PET) > 1) stop("Only one PET style publication bias adjustment is allowed.") + + named_prior_PET <- prior_list[[which(is_PET)]] + class(named_prior_PET) <- class(named_prior_PET)[!class(named_prior_PET) %in% "prior.PET"] + named_prior_PET <- list("PET_1" = named_prior_PET) + + init <- c(init, .JAGS_get_inits.fun(named_prior_PET)) + } + if(any(is_PEESE)){ + if(sum(is_PEESE) > 1) stop("Only one PEESE style publication bias adjustment is allowed.") + + named_prior_PEESE <- prior_list[[which(is_PEESE)]] + class(named_prior_PEESE) <- class(named_prior_PEESE)[!class(named_prior_PEESE) %in% "prior.PEESE"] + named_prior_PEESE <- list("PEESE_1" = named_prior_PEESE) + + init <- c(init, .JAGS_get_inits.fun(named_prior_PEESE)) + } + if(any(is_weightfunction)){ + + # find prior with the most alpha parameters and simulate initial values from it + alpha <- sapply(prior_list[is_weightfunction], function(x){ + if(grepl("fixed", x[["distribution"]])){ + return(length(x$parameters[["omega"]])) + }else{ + return(length(x$parameters[["alpha"]])) + } + }) + + init <- c(init, .JAGS_get_inits.fun(prior_list[is_weightfunction][which.max(alpha)])) + } + + init[["bias_indicator"]] <- rng(prior_list, 1, sample_components = TRUE) + + }else{ + + prior_components <- as.list(prior_list) + class(prior_components) <- "list" + names(prior_components) <- paste0(parameter_name, "_component_", seq_along(prior_components)) + + init <- .JAGS_get_inits.fun(prior_components) + init[[paste0(parameter_name, "_indicator")]] <- rng(prior_list, 1, sample_components = TRUE) + + } + + return(init) +} #' @title Create list of monitored parameters for 'JAGS' model @@ -1034,6 +1358,10 @@ JAGS_to_monitor <- function(prior_list){ monitor <- c(monitor, .JAGS_monitor.spike_and_slab(prior_list[[i]], names(prior_list)[i])) + }else if(is.prior.mixture(prior_list[[i]])){ + + monitor <- c(monitor, .JAGS_monitor.mixture(prior_list[[i]], names(prior_list)[i])) + }else if(is.prior.factor(prior_list[[i]])){ monitor <- c(monitor, .JAGS_monitor.factor(prior_list[[i]], names(prior_list)[i])) @@ -1122,14 +1450,57 @@ JAGS_to_monitor <- function(prior_list){ names(prior_inclusion) <- paste0(parameter_name, "_inclusion") monitor <- c( - parameter_name, - JAGS_to_monitor(prior_variable), + paste0(parameter_name, "_indicator"), JAGS_to_monitor(prior_inclusion), - paste0(parameter_name, "_indicator") + parameter_name, + JAGS_to_monitor(prior_variable) ) return(monitor) } +.JAGS_monitor.mixture <- function(prior_list, parameter_name){ + + .check_prior_list(prior_list) + if(!is.prior.mixture(prior_list)) + stop("improper prior provided") + check_char(parameter_name, "parameter_name") + + if(inherits(prior_list, "prior.bias_mixture")){ + + # dispatch between publication bias prior mixture and a standard prior mixture + is_PET <- sapply(prior_list, is.prior.PET) + is_PEESE <- sapply(prior_list, is.prior.PEESE) + is_weightfunction <- sapply(prior_list, is.prior.weightfunction) + is_none <- sapply(prior_list, is.prior.none) + + monitor <- "bias_indicator" + + # if any prior is bias related, the whole component must be dispatching publication bias + if(any(!(is_PET | is_PEESE | is_weightfunction | is_none))) + stop("Mixture of publication bias and standard priors is not supported.") + + if(any(is_PET)){ + if(sum(is_PET) > 1) stop("Only one PET style publication bias adjustment is allowed.") + + monitor <- c(monitor, "PET") + } + if(any(is_PEESE)){ + if(sum(is_PEESE) > 1) stop("Only one PEESE style publication bias adjustment is allowed.") + + monitor <- c(monitor, "PEESE") + } + if(any(is_weightfunction)){ + + monitor <- c(monitor, "omega") + } + + }else{ + + monitor <- c(paste0(parameter_name, "_indicator"), parameter_name) + } + + return(monitor) +} #' @title Check and list 'JAGS' fitting settings #' diff --git a/R/JAGS-formula.R b/R/JAGS-formula.R index a7126f48..c42a27a1 100644 --- a/R/JAGS-formula.R +++ b/R/JAGS-formula.R @@ -91,11 +91,7 @@ JAGS_formula <- function(formula, parameter, data, prior_list){ for(factor in names(predictors_type[predictors_type == "factor"])){ # select the corresponding prior for the variable - if(is.prior.spike_and_slab(prior_list[[factor]])){ - this_prior <- prior_list[[factor]][["variable"]] - }else{ - this_prior <- prior_list[[factor]] - } + this_prior <- prior_list[[factor]] if(is.prior.treatment(this_prior)){ stats::contrasts(data[,factor]) <- "contr.treatment" @@ -115,13 +111,9 @@ JAGS_formula <- function(formula, parameter, data, prior_list){ for(continuous in names(predictors_type[predictors_type == "continuous"])){ # select the corresponding prior for the variable - if(is.prior.spike_and_slab(prior_list[[continuous]])){ - this_prior <- prior_list[[continuous]][["variable"]] - }else{ - this_prior <- prior_list[[continuous]] - } + this_prior <- prior_list[[continuous]] - if(is.prior.factor(this_prior)){ + if(is.prior.factor(this_prior)|| is.prior.discrete(this_prior) || is.prior.PET(this_prior) || is.prior.PEESE(this_prior) || is.prior.weightfunction(this_prior)){ stop(paste0("Unsupported prior distribution defined for '", continuous, "' continuous variable. See '?prior' for details.")) } } @@ -155,7 +147,9 @@ JAGS_formula <- function(formula, parameter, data, prior_list){ terms_indexes[1] <- 0 formula_syntax <- c(formula_syntax, paste0(parameter, "_intercept")) - prior_syntax <- c(prior_syntax, .JAGS_prior.simple(prior_list[["intercept"]], paste0(parameter, "_intercept"))) + prior_intercept_list <- prior_list["intercept"] + names(prior_intercept_list) <- paste0(parameter, "_intercept") + prior_syntax <- c(prior_syntax, .JAGS_add_priors.fun(prior_intercept_list)) }else{ terms_indexes <- attr(model_matrix, "assign") } @@ -164,11 +158,7 @@ JAGS_formula <- function(formula, parameter, data, prior_list){ for(i in unique(terms_indexes[terms_indexes > 0])){ # extract the corresponding prior distribution for a given coefficient - if(is.prior.spike_and_slab(prior_list[[model_terms[i]]])){ - this_prior <- prior_list[[model_terms[i]]][["variable"]] - }else{ - this_prior <- prior_list[[model_terms[i]]] - } + this_prior <- prior_list[[model_terms[i]]] # check whether the term is an interaction or not and save the corresponding attributes attr(this_prior, "interaction") <- grepl("__xXx__", model_terms[i]) @@ -225,8 +215,21 @@ JAGS_formula <- function(formula, parameter, data, prior_list){ } # update the corresponding prior distribution back into the prior list - if(is.prior.spike_and_slab(prior_list[[model_terms[i]]])){ - this_prior -> prior_list[[model_terms[i]]][["variable"]] + # (and forward attributes to lower level components in the case of spike and slab and mixture priors) + if(is.prior.spike_and_slab(this_prior)){ + attr(this_prior, "levels") -> attr(this_prior[["variable"]], "levels") + attr(this_prior, "level_names") -> attr(this_prior[["variable"]], "level_names") + attr(this_prior, "interaction") -> attr(this_prior[["variable"]], "interaction") + attr(this_prior, "interaction_terms") -> attr(this_prior[["variable"]], "interaction_terms") + this_prior -> prior_list[[model_terms[i]]] + }else if(is.prior.mixture(this_prior)){ + for(p in seq_along(this_prior)){ + attr(this_prior, "levels") -> attr(this_prior[[p]], "levels") + attr(this_prior, "level_names") -> attr(this_prior[[p]], "level_names") + attr(this_prior, "interaction") -> attr(this_prior[[p]], "interaction") + attr(this_prior, "interaction_terms") -> attr(this_prior[[p]], "interaction_terms") + } + this_prior -> prior_list[[model_terms[i]]] }else{ this_prior -> prior_list[[model_terms[i]]] } @@ -337,11 +340,7 @@ JAGS_evaluate_formula <- function(fit, formula, parameter, data, prior_list){ for(factor in names(predictors_type[predictors_type == "factor"])){ # select the corresponding prior in the variable - if(is.prior.spike_and_slab(prior_list_formula[[factor]])){ - this_prior <- prior_list_formula[[factor]][["variable"]] - }else{ - this_prior <- prior_list_formula[[factor]] - } + this_prior <- prior_list_formula[[factor]] if(is.factor(data[,factor])){ if(all(levels(data[,factor]) %in% .get_prior_factor_level_names(this_prior))){ @@ -378,13 +377,9 @@ JAGS_evaluate_formula <- function(fit, formula, parameter, data, prior_list){ for(continuous in names(predictors_type[predictors_type == "continuous"])){ # select the corresponding prior in the variable - if(is.prior.spike_and_slab(prior_list_formula[[continuous]])){ - this_prior <- prior_list_formula[[continuous]][["variable"]] - }else{ - this_prior <- prior_list_formula[[continuous]] - } + this_prior <- prior_list_formula[[continuous]] - if(is.prior.factor(this_prior)){ + if(is.prior.factor(this_prior)|| is.prior.discrete(this_prior) || is.prior.PET(this_prior) || is.prior.PEESE(this_prior) || is.prior.weightfunction(this_prior)){ stop(paste0("Unsupported prior distribution defined for '", continuous, "' continuous variable. See '?prior' for details.")) } } diff --git a/R/JAGS-marglik.R b/R/JAGS-marglik.R index 678f9fd7..89fc3e51 100644 --- a/R/JAGS-marglik.R +++ b/R/JAGS-marglik.R @@ -273,8 +273,12 @@ JAGS_bridgesampling_posterior <- function(posterior, prior_list, add_parameters stop("lb' and 'ub' must be numeric vectors.") } + # these are not generally possible because the component indicators are discrete and bridgesampling + # package cannot currently deal with them if(any(sapply(prior_list, is.prior.spike_and_slab))) stop("Marginal likelihood computation for spike and slab priors is not implemented.") + if(any(sapply(prior_list, is.prior.mixture))) + stop("Marginal likelihood computation for prior mixture priors is not implemented.") # get information about the specified parameters parameters_names <- .JAGS_bridgesampling_posterior_info(prior_list) @@ -329,10 +333,6 @@ JAGS_bridgesampling_posterior <- function(posterior, prior_list, add_parameters add_parameter <- .JAGS_bridgesampling_posterior_info.PP(prior_list[[i]]) - }else if(is.prior.spike_and_slab(prior_list[[i]])){ - - add_parameter <- .JAGS_bridgesampling_posterior_info.spike_and_slab(prior_list[[i]], names(prior_list)[i]) - }else if(is.prior.factor(prior_list[[i]])){ add_parameter <- .JAGS_bridgesampling_posterior_info.factor(prior_list[[i]], names(prior_list)[i]) @@ -496,33 +496,33 @@ JAGS_bridgesampling_posterior <- function(posterior, prior_list, add_parameters return(parameter) } -.JAGS_bridgesampling_posterior_info.spike_and_slab <- function(prior, parameter_name){ - - .check_prior(prior) - if(!is.prior.spike_and_slab(prior)) - stop("improper prior provided") - check_char(parameter_name, "parameter_name") - - if(!is.prior.point(prior[["inclusion"]])){ - - parameter_variable <- .JAGS_bridgesampling_posterior_info.simple(prior[["variable"]], paste0(parameter_name, "_variable")) - parameter_inclusion <- .JAGS_bridgesampling_posterior_info.simple(prior[["inclusion"]], paste0(parameter_name, "_inclusion")) - - parameter <- c(parameter_variable, parameter_inclusion) - - attr(parameter, "lb") <- c(attr(parameter_variable, "lb"), attr(parameter_inclusion, "lb")) - attr(parameter, "ub") <- c(attr(parameter_variable, "ub"), attr(parameter_inclusion, "ub")) - - names(attr(parameter, "lb")) <- c(names(attr(parameter_variable, "lb")), names(attr(parameter_inclusion, "lb"))) - names(attr(parameter, "ub")) <- c(names(attr(parameter_variable, "ub")), names(attr(parameter_inclusion, "ub"))) - - }else{ - parameter <- .JAGS_bridgesampling_posterior_info.simple(prior[["variable"]], paste0(parameter_name, "_variable")) - } - - - return(parameter) -} +# .JAGS_bridgesampling_posterior_info.spike_and_slab <- function(prior, parameter_name){ +# +# .check_prior(prior) +# if(!is.prior.spike_and_slab(prior)) +# stop("improper prior provided") +# check_char(parameter_name, "parameter_name") +# +# if(!is.prior.point(prior[["inclusion"]])){ +# +# parameter_variable <- .JAGS_bridgesampling_posterior_info.simple(prior[["variable"]], paste0(parameter_name, "_variable")) +# parameter_inclusion <- .JAGS_bridgesampling_posterior_info.simple(prior[["inclusion"]], paste0(parameter_name, "_inclusion")) +# +# parameter <- c(parameter_variable, parameter_inclusion) +# +# attr(parameter, "lb") <- c(attr(parameter_variable, "lb"), attr(parameter_inclusion, "lb")) +# attr(parameter, "ub") <- c(attr(parameter_variable, "ub"), attr(parameter_inclusion, "ub")) +# +# names(attr(parameter, "lb")) <- c(names(attr(parameter_variable, "lb")), names(attr(parameter_inclusion, "lb"))) +# names(attr(parameter, "ub")) <- c(names(attr(parameter_variable, "ub")), names(attr(parameter_inclusion, "ub"))) +# +# }else{ +# parameter <- .JAGS_bridgesampling_posterior_info.simple(prior[["variable"]], paste0(parameter_name, "_variable")) +# } +# +# +# return(parameter) +# } #' @title Compute marginal likelihood for 'JAGS' priors #' @@ -569,10 +569,6 @@ JAGS_marglik_priors <- function(samples, prior_list){ marglik <- marglik + .JAGS_marglik_priors.PP(samples, prior_list[[i]]) - }else if(is.prior.spike_and_slab(prior_list[[i]])){ - - marglik <- marglik + .JAGS_marglik_priors.spike_and_slab(samples, prior_list[[i]], names(prior_list)[i]) - }else if(is.prior.factor(prior_list[[i]])){ marglik <- marglik + .JAGS_marglik_priors.factor(samples, prior_list[[i]], names(prior_list)[i]) @@ -703,24 +699,24 @@ JAGS_marglik_priors <- function(samples, prior_list){ return(marglik) } -.JAGS_marglik_priors.spike_and_slab <- function(samples, prior, parameter_name){ - - .check_prior(prior) - if(!is.prior.spike_and_slab(prior)) - stop("improper prior provided") - check_char(parameter_name, "parameter_name") - - marglik <- 0 - if(!is.prior.point(prior[["inclusion"]])){ - marglik <- marglik + .JAGS_marglik_priors.simple(samples, prior[["inclusion"]], paste0(parameter_name, "_inclusion")) - } - - if(samples[[ paste0(if(prior[["variable"]][["distribution"]] == "invgamma") "inv_" else "", parameter_name, "_variable") ]] != 0){ - marglik <- marglik + .JAGS_marglik_priors.simple(samples, prior[["variable"]], paste0(parameter_name, "_variable")) - } - - return(marglik) -} +# .JAGS_marglik_priors.spike_and_slab <- function(samples, prior, parameter_name){ +# +# .check_prior(prior) +# if(!is.prior.spike_and_slab(prior)) +# stop("improper prior provided") +# check_char(parameter_name, "parameter_name") +# +# marglik <- 0 +# if(!is.prior.point(prior[["inclusion"]])){ +# marglik <- marglik + .JAGS_marglik_priors.simple(samples, prior[["inclusion"]], paste0(parameter_name, "_inclusion")) +# } +# +# if(samples[[ paste0(if(prior[["variable"]][["distribution"]] == "invgamma") "inv_" else "", parameter_name, "_variable") ]] != 0){ +# marglik <- marglik + .JAGS_marglik_priors.simple(samples, prior[["variable"]], paste0(parameter_name, "_variable")) +# } +# +# return(marglik) +# } #' @rdname JAGS_marglik_priors JAGS_marglik_priors_formula <- function(samples, formula_prior_list){ @@ -780,10 +776,6 @@ JAGS_marglik_parameters <- function(samples, prior_list){ parameters <- c(parameters, .JAGS_marglik_parameters.PP(samples, prior_list[[i]])) - }else if(is.prior.spike_and_slab(prior_list[[i]])){ - - parameters <- c(parameters, .JAGS_marglik_parameters.spike_and_slab(samples, prior_list[[i]], names(prior_list)[i])) - }else if(is.prior.factor(prior_list[[i]])){ parameters <- c(parameters, .JAGS_marglik_parameters.factor(samples, prior_list[[i]], names(prior_list)[i])) @@ -925,21 +917,21 @@ JAGS_marglik_parameters <- function(samples, prior_list){ return(parameter) } -.JAGS_marglik_parameters.spike_and_slab <- function(samples, prior, parameter_name){ - - .check_prior(prior) - if(!is.prior.spike_and_slab(prior)) - stop("improper prior provided") - check_char(parameter_name, "parameter_name") - - parameter <- list() - parameter[paste0(parameter_name, "_variable")] <- .JAGS_marglik_parameters.simple(samples, prior[["variable"]], paste0(parameter_name, "_variable")) - if(!is.prior.point(prior[[parameter_name]][["inclusion"]])){ - parameter[paste0(parameter_name, "_inclusion")] <- .JAGS_marglik_parameters.simple(samples, prior[["inclusion"]], paste0(parameter_name, "_inclusion")) - } - - return(parameter) -} +# .JAGS_marglik_parameters.spike_and_slab <- function(samples, prior, parameter_name){ +# +# .check_prior(prior) +# if(!is.prior.spike_and_slab(prior)) +# stop("improper prior provided") +# check_char(parameter_name, "parameter_name") +# +# parameter <- list() +# parameter[paste0(parameter_name, "_variable")] <- .JAGS_marglik_parameters.simple(samples, prior[["variable"]], paste0(parameter_name, "_variable")) +# if(!is.prior.point(prior[[parameter_name]][["inclusion"]])){ +# parameter[paste0(parameter_name, "_inclusion")] <- .JAGS_marglik_parameters.simple(samples, prior[["inclusion"]], paste0(parameter_name, "_inclusion")) +# } +# +# return(parameter) +# } #' @rdname JAGS_marglik_parameters JAGS_marglik_parameters_formula <- function(samples, formula_data_list, formula_prior_list, prior_list_parameters){ diff --git a/R/interpret.R b/R/interpret.R index ebab153e..67af4a70 100644 --- a/R/interpret.R +++ b/R/interpret.R @@ -21,8 +21,14 @@ #' #' @return \code{interpret} returns character. #' +#' @export interpret +#' @export interpret2 +#' @name interpret +#' #' @seealso [ensemble_inference] [mix_posteriors] [BayesTools_model_tables] [BayesTools_ensemble_tables] -#' @export +NULL + +#' @rdname interpret interpret <- function(inference, samples, specification, method){ # check input @@ -50,7 +56,33 @@ interpret <- function(inference, samples, specification, method){ return(output) } -.interpret.specification <- function(inference, samples, specification, method){ +#' @rdname interpret +interpret2 <- function(specification, method = NULL){ + + # check input + check_list(specification, "specification", check_length = 0) + sapply(specification, function(s){ + check_char(s$inference_name, "inference_name", allow_NULL = TRUE) + check_char(s$inference_BF_name, "inference_BF_name", allow_NULL = TRUE) + check_real(s$inference_BF, "inference_BF", allow_NULL = TRUE) + check_char(s$estimate_name, "estimate_name", allow_NULL = TRUE) + check_real(s$estimate_samples, "estimate_samples", allow_NULL = TRUE, check_length = 0) + check_char(s$estimate_units, "estimate_units", allow_NULL = TRUE) + check_bool(s$estimate_conditional, "estimate_conditional", allow_NULL = TRUE) + }) + check_char(method, allow_NULL = TRUE) + + + output <- "" + + for(i in seq_along(specification)){ + output <- paste0(output, .interpret.specification2(specification[[i]], method), if(i != length(specification)) " ") + } + + return(output) +} + +.interpret.specification <- function(inference, samples, specification, method){ temp_BF <- inference[[specification[["inference"]]]][["BF"]] text_BF <- .interpret.BF(temp_BF, if(!is.null(specification[["inference_name"]])) specification[["inference_name"]] else specification[["inference"]], @@ -66,7 +98,19 @@ interpret <- function(inference, samples, specification, method){ return(paste0(method, " found ", text_BF, ", ", text_par, ".")) } -.interpret.BF <- function(BF, name, BF_name){ +.interpret.specification2 <- function(specification, method){ + + text_BF <- .interpret.BF(specification[["inference_BF"]], specification[["inference_name"]], specification[["inference_BF_name"]]) + + if(is.null(specification[["estimate_samples"]])){ + return(paste0(method, " found ", text_BF, ".")) + } + + text_par <- .interpret.par(specification[["estimate_samples"]], specification[["estimate_name"]], specification[["estimate_units"]], specification[["estimate_conditional"]]) + + return(paste0(method, " found ", text_BF, ", ", text_par, ".")) +} +.interpret.BF <- function(BF, name, BF_name){ if(abs(log(BF)) > log(10)){ text <- "strong evidence" @@ -92,7 +136,7 @@ interpret <- function(inference, samples, specification, method){ return(text) } -.interpret.par <- function(samples, name, unit, conditional){ +.interpret.par <- function(samples, name, unit, conditional){ est <- mean(samples) CI <- unname(stats::quantile(samples, probs = c(0.025, 0.975))) diff --git a/R/marginal-distributions.R b/R/marginal-distributions.R index 0f63d568..0801a59c 100644 --- a/R/marginal-distributions.R +++ b/R/marginal-distributions.R @@ -15,7 +15,7 @@ #' \code{contrast = "orthonormal"}, and \code{contrast = "independent"} levels #' @param use_formula whether the parameter should be evaluated as a part of supplied formula #' @param n_samples number of samples to be drawn for the model-averaged -#' posterior distribution +#' prior distribution #' @inheritParams density.prior #' #' @return \code{marginal_posterior} returns a named list of mixed marginal posterior @@ -27,7 +27,7 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr n_samples = 10000, ...){ check_list(samples, "samples") - if(any(!sapply(samples, inherits, what = "mixed_posteriors"))) + if(!inherits(samples, "mixed_posteriors")) stop("'samples' must be a be an object generated by 'mix_posteriors' function.") check_char(parameter, "parameter", allow_values = names(samples)) if(!is.null(formula) && !is.language(formula)) @@ -204,7 +204,7 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr # obtain samples information models_ind <- do.call(cbind, lapply(c(if(has_intercept) "intercept", model_terms), function(x) attr(samples[[JAGS_parameter_names(x, formula_parameter = formula_parameter)]], "models_ind"))) sample_ind <- do.call(cbind, lapply(c(if(has_intercept) "intercept", model_terms), function(x) attr(samples[[JAGS_parameter_names(x, formula_parameter = formula_parameter)]], "sample_ind"))) - if(!all(models_ind[,1] == models_ind) || !all(sample_ind[,1] == sample_ind)) + if(!inherits(samples, "as_mixed_posteriors") && (!all(models_ind[,1] == models_ind) || !all(sample_ind[,1] == sample_ind))) stop("the posterior samples are not alligned across models/draws") models_ind <- models_ind[,1] @@ -216,8 +216,15 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr terms_indexes[1] <- 0 # get model/sample indices and check for scaling factors - temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix(JAGS_parameter_names("intercept", formula_parameter = formula_parameter), - prior_list = prior_list, posterior = posterior_samples_matrix, models_ind = models_ind, nrow = nrow(data)) + temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix( + JAGS_parameter_names("intercept", formula_parameter = formula_parameter), + prior_list = prior_list, + posterior = posterior_samples_matrix, + models_ind = models_ind, + nrow = nrow(data), + simple_list = inherits(samples, "as_mixed_posteriors") + ) + marginal_posterior_samples <- temp_multiply_by * matrix(posterior_samples_matrix[,JAGS_parameter_names("intercept", formula_parameter = formula_parameter)], nrow = nrow(data), ncol = nrow(posterior_samples_matrix), byrow = TRUE) @@ -241,7 +248,14 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr ,drop = FALSE] # check for scaling factors - temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix(JAGS_model_terms[i], prior_list = prior_list, posterior = posterior_samples_matrix, models_ind = models_ind, nrow = nrow(data)) + temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix( + JAGS_model_terms[i], + prior_list = prior_list, + posterior = posterior_samples_matrix, + models_ind = models_ind, + nrow = nrow(data), + simple_list = inherits(samples, "as_mixed_posteriors") + ) marginal_posterior_samples <- marginal_posterior_samples + temp_multiply_by * (temp_data %*% t(temp_posterior)) @@ -317,7 +331,12 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr if(prior_samples){ ### generate prior samples matrix in the same format as are the posterior samples - prior_samples <- .mix_priors(prior_list = prior_list, n_samples = n_samples) + if(inherits(samples, "as_mixed_posteriors")){ + prior_samples <- .as_mixed_priors(prior_list = prior_list, n_samples = n_samples, conditional = attr(samples, "conditional", exact = TRUE), conditional_rule = attr(samples, "conditional_rule")) + }else{ + prior_samples <- .mix_priors(prior_list = prior_list, n_samples = n_samples) + } + for(i in seq_along(prior_samples)){ # de-name factor levels if(priors_info[[i]][["factor"]]){ @@ -334,7 +353,7 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr # obtain prior_samples information models_ind <- do.call(cbind, lapply(c(if(has_intercept) "intercept", model_terms), function(x) attr(prior_samples[[JAGS_parameter_names(x, formula_parameter = formula_parameter)]], "models_ind"))) sample_ind <- do.call(cbind, lapply(c(if(has_intercept) "intercept", model_terms), function(x) attr(prior_samples[[JAGS_parameter_names(x, formula_parameter = formula_parameter)]], "sample_ind"))) - if(!all(models_ind[,1] == models_ind) || !all(sample_ind[,1] == sample_ind)) + if(!inherits(samples, "as_mixed_posteriors") && (!all(models_ind[,1] == models_ind) || !all(sample_ind[,1] == sample_ind))) stop("the prior prior_samples are not alligned across models/draws") models_ind <- models_ind[,1] @@ -346,8 +365,14 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr terms_indexes[1] <- 0 # get model/sample indices and check for scaling factors - temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix(JAGS_parameter_names("intercept", formula_parameter = formula_parameter), - prior_list = prior_list, posterior = prior_samples_matrix, models_ind = models_ind, nrow = nrow(data)) + temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix( + JAGS_parameter_names("intercept", formula_parameter = formula_parameter), + prior_list = prior_list, + posterior = prior_samples_matrix, + models_ind = models_ind, + nrow = nrow(data), + simple_list = inherits(samples, "as_mixed_posteriors") + ) marginal_prior_samples <- temp_multiply_by * matrix(prior_samples_matrix[,JAGS_parameter_names("intercept", formula_parameter = formula_parameter)], nrow = nrow(data), ncol = nrow(prior_samples_matrix), byrow = TRUE) @@ -371,7 +396,14 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr ,drop = FALSE] # check for scaling factors - temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix(JAGS_model_terms[i], prior_list = prior_list, posterior = prior_samples_matrix, models_ind = models_ind, nrow = nrow(data)) + temp_multiply_by <- .get_combined_parameter_scaling_factor_matrix( + JAGS_model_terms[i], + prior_list = prior_list, + posterior = prior_samples_matrix, + models_ind = models_ind, + nrow = nrow(data), + simple_list = inherits(samples, "as_mixed_posteriors") + ) marginal_prior_samples <- marginal_prior_samples + temp_multiply_by * (temp_data %*% t(temp_prior)) @@ -480,7 +512,11 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr # add prior samples if(prior_samples){ - prior_samples <- .mix_priors(prior_list = prior_list, n_samples = n_samples) + if(inherits(samples, "as_mixed_posteriors")){ + prior_samples <- .as_mixed_priors(prior_list = prior_list, n_samples = n_samples, conditional = attr(samples, "conditional", exact = TRUE), conditional_rule = attr(samples, "conditional_rule")) + }else{ + prior_samples <- .mix_priors(prior_list = prior_list, n_samples = n_samples) + } marginal_prior_samples <- prior_samples[[parameter]] # transform if factors @@ -533,15 +569,19 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr return(marginal_posterior_samples) } -.get_combined_parameter_scaling_factor_matrix <- function(term, prior_list, posterior, models_ind, nrow){ +.get_combined_parameter_scaling_factor_matrix <- function(term, prior_list, posterior, models_ind, nrow, simple_list = FALSE){ - model_samples <- table(models_ind) + if(simple_list){ + temp_multiply_by <- .get_parameter_scaling_factor_matrix(term, prior_list, posterior, nrow = nrow, ncol = nrow(posterior)) + }else{ + model_samples <- table(models_ind) - temp_multiply_by <- do.call(cbind, lapply(unique(models_ind), function(m){ - temp_prior_list <- lapply(prior_list, function(parameter_priors) parameter_priors[[m]]) - temp_posterior <- posterior[models_ind == m,,drop=FALSE] - return(.get_parameter_scaling_factor_matrix(term, temp_prior_list, temp_posterior, nrow = nrow, ncol = sum(models_ind == m))) - })) + temp_multiply_by <- do.call(cbind, lapply(unique(models_ind), function(m){ + temp_prior_list <- lapply(prior_list, function(parameter_priors) parameter_priors[[m]]) + temp_posterior <- posterior[models_ind == m,,drop=FALSE] + return(.get_parameter_scaling_factor_matrix(term, temp_prior_list, temp_posterior, nrow = nrow, ncol = sum(models_ind == m))) + })) + } return(temp_multiply_by) } @@ -668,10 +708,10 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr models_ind <- NULL # mix samples - for(i in seq_along(priors)[round(prior_probs * n_samples) > 1]){ + for(i in seq_along(priors)[ceiling(prior_probs * n_samples) >= 1]){ # sample indexes - temp_ind <- 1:round(n_samples * prior_probs[i]) + temp_ind <- 1:ceiling(n_samples * prior_probs[i]) # sample prior samples <- c(samples, rng(priors[[i]], length(temp_ind), transform_factor_samples = FALSE)) @@ -680,6 +720,11 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr models_ind <- c(models_ind, rep(i, length(temp_ind))) } + # assure the correct number of samples + samples <- samples[1:n_samples] + sample_ind <- sample_ind[1:n_samples] + models_ind <- models_ind[1:n_samples] + samples <- unname(samples) attr(samples, "sample_ind") <- sample_ind attr(samples, "models_ind") <- models_ind @@ -718,10 +763,10 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr models_ind <- NULL # mix samples - for(i in seq_along(priors)[round(prior_probs * n_samples) > 1]){ + for(i in seq_along(priors)[ceiling(prior_probs * n_samples) > 1]){ # sample indexes - temp_ind <- 1:round(n_samples * prior_probs[i]) + temp_ind <- 1:ceiling(n_samples * prior_probs[i]) if(is.prior.point(priors[[i]]) & is.prior.simple(priors[[i]])){ # not sampling the priors in case they were imputed (missing dimensions) @@ -736,6 +781,11 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr models_ind <- c(models_ind, rep(i, length(temp_ind))) } + # assure the correct number of samples + samples <- samples[1:n_samples,,drop=FALSE] + sample_ind <- sample_ind[1:n_samples] + models_ind <- models_ind[1:n_samples] + rownames(samples) <- NULL colnames(samples) <- paste0(parameter,"[",1:K,"]") attr(samples, "sample_ind") <- sample_ind @@ -902,10 +952,10 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr models_ind <- NULL # mix samples - for(i in seq_along(priors)[round(prior_probs * n_samples) > 1]){ + for(i in seq_along(priors)[ceiling(prior_probs * n_samples) > 1]){ # sample indexes - temp_ind <- 1:round(n_samples * prior_probs[i]) + temp_ind <- 1:ceiling(n_samples * prior_probs[i]) if(is.prior.none(priors[[i]])){ samples <- rbind(samples, matrix(1, ncol = length(omega_cuts) - 1, nrow = length(temp_ind))) @@ -920,6 +970,11 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr models_ind <- c(models_ind, rep(i, length(temp_ind))) } + # assure the correct number of samples + samples <- samples[1:n_samples,,drop=FALSE] + sample_ind <- sample_ind[1:n_samples] + models_ind <- models_ind[1:n_samples] + rownames(samples) <- NULL colnames(samples) <- omega_names attr(samples, "sample_ind") <- sample_ind @@ -931,6 +986,428 @@ marginal_posterior <- function(samples, parameter, formula = NULL, at = NULL, pr return(samples) } +.as_mixed_priors <- function(prior_list, seed = NULL, n_samples = 10000, conditional = NULL, conditional_rule = NULL){ + + check_list(prior_list, "prior_list") + if(any(!sapply(prior_list, is.prior))) + stop("'prior_list' must be a list of prior distributions") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + # set seed only once at the beginning -- not in the individual draws as the priors will end up completely correlated + if(is.null(seed)){ + seed <- sample(.Machine$integer.max, 1) + } + set.seed(seed) + + # adapted from 'as_mixed_posteriors' + parameters <- names(prior_list) + out <- list() + + # estimate the number of necessary samples for conditioning + if(length(conditional) > 0){ + + conditioning_probabilities <- sapply(conditional, function(parameter){ + + temp_prior <- prior_list[[parameter]] + + if(is.prior.spike_and_slab(temp_prior)){ + + return(mean(temp_prior[["inclusion"]])) + + }else if(is.prior.mixture(temp_prior)){ + + components <- attr(temp_prior, "components") + prior_weights <- attr(temp_prior, "prior_weights") + + if(!all(components %in% c("null", "alternative"))) + stop("conditional mixture posterior distributions are available only for 'null' and 'alternative' components") + + return(sum(prior_weights[components == "alternative"]) / sum(prior_weights)) + + }else{ + + warning(sprintf("The parameter '%s' is not a conditional parameter.", parameter), call. = FALSE, immediate. = TRUE) + return(1) + } + }) + + # multiply by 1.25 to ensure that the requested number of samples is reached + requested_samples <- n_samples + if(conditional_rule == "AND"){ + n_samples <- round(n_samples / prod(conditioning_probabilities) * 1.25) + }else if(conditional_rule == "OR"){ + n_samples <- round(n_samples / (1 - prod(1 - conditioning_probabilities)) * 1.25) + } + } + + # create the samples + for(p in seq_along(parameters)){ + + # prepare parameter specific values + temp_parameter <- parameters[p] + temp_prior <- prior_list[[temp_parameter]] + + if(is.prior.spike_and_slab(temp_prior)){ + # spike and slab priors + out[[temp_parameter]] <- .as_mixed_priors.spike_and_slab(temp_prior, temp_parameter, NULL, n_samples) + + }else if(is.prior.mixture(temp_prior)){ + # mixture priors + out[[temp_parameter]] <- .as_mixed_priors.mixture(temp_prior, temp_parameter, NULL, n_samples) + + }else if(is.prior.weightfunction(temp_prior)){ + # weightfunctions: + out[[temp_parameter]] <- .as_mixed_priors.weightfunction(temp_prior, temp_parameter, NULL, n_samples) + + }else if(is.prior.factor(temp_prior)){ + # factor priors + out[[temp_parameter]] <- .as_mixed_priors.factor(temp_prior, temp_parameter, NULL, n_samples) + + }else if(is.prior.vector(temp_prior)){ + # vector priors: + out[[temp_parameter]] <- .as_mixed_priors.vector(temp_prior, temp_parameter, NULL, n_samples) + + }else if(is.prior.simple(temp_prior)){ + # simple priors: + out[[temp_parameter]] <- .as_mixed_priors.simple(temp_prior, temp_parameter, NULL, n_samples) + + }else{ + stop("The posterior samples cannot be mixed: unsupported mixture of prior distributions.") + } + + # add formula relevant information + if(!is.null(attr(temp_prior, which = "parameter"))){ + class(out[[temp_parameter]]) <- c(class(out[[temp_parameter]]), "mixed_posteriors.formula") + attr(out[[temp_parameter]], "formula_parameter") <- attr(temp_prior, which = "parameter") + } + } + + + # perform conditioning (and copy back with attributes) + if(length(conditional) > 0){ + + # obtain the indicator samples + conditioning_samples <- do.call(cbind, lapply(conditional, function(parameter){ + + temp_prior <- prior_list[[parameter]] + + if(is.prior.spike_and_slab(temp_prior)){ + + return(attr(out[[parameter]], "models_ind") == 1) + + }else if(is.prior.mixture(temp_prior)){ + + components <- attr(temp_prior, "components") + return(attr(out[[parameter]], "models_ind") %in% which(components == "alternative")) + + }else{ + + return(rep(TRUE, n_samples)) + } + })) + conditioning_samples <- apply(conditioning_samples, 1, ifelse(conditional_rule == "AND", all, any)) + + # check enough samples were drawn (if too many remove the extra ones) + if(sum(conditioning_samples) < requested_samples){ + warning(sprintf("Only %d samples were drawn from the prior distributions due to conditioning.", sum(conditioning_samples))) + }else{ + conditioning_samples[which(conditioning_samples)[-(1:requested_samples)]] <- FALSE + } + + # select the conditional samples (and copy attributes) + for(p in seq_along(parameters)){ + temp <- attributes(out[[parameters[p]]]) + if(is.null(dim(out[[parameters[p]]]))){ + out[[parameters[p]]] <- out[[parameters[p]]][conditioning_samples] + attributes(out[[parameters[p]]]) <- c(attributes(out[[parameters[p]]]), temp) + attr(out[[parameters[p]]], "models_ind") <- attr(out[[parameters[p]]], "models_ind")[conditioning_samples] + }else{ + out[[parameters[p]]] <- out[[parameters[p]]][conditioning_samples,,drop=FALSE] + attributes(out[[parameters[p]]]) <- c(attributes(out[[parameters[p]]])[!names(attributes(out[[parameters[p]]])) %in% c("dimnames")], temp[!names(temp) %in% c("dim")]) + attr(out[[parameters[p]]], "models_ind") <- attr(out[[parameters[p]]], "models_ind")[conditioning_samples] + } + } + } + + return(out) +} +.as_mixed_priors.simple <- function(prior, parameter, seed = NULL, n_samples = 10000){ + + # check input + check_list(prior, "prior") + check_char(parameter, "parameter") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + # do not set seed when sampling multiple prior for the same model -- they will end up completely correlated + if(!is.null(seed)){ + set.seed(seed) + } + + # prepare output objects + samples <- rng(prior, n_samples, transform_factor_samples = FALSE) + + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.simple") + + return(samples) +} +.as_mixed_priors.vector <- function(prior, parameter, seed = NULL, n_samples = 10000){ + + # check input + check_list(prior, "prior") + check_char(parameter, "parameter") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + # do not set seed when sampling multiple prior for the same model -- they will end up completely correlated + if(!is.null(seed)){ + set.seed(seed) + } + + # prepare output objects + K <- prior$parameters[["K"]] + + if(is.prior.point(prior) & is.prior.simple(prior)){ + # not sampling the prior in case they were imputed (missing dimensions) + samples <- matrix(prior$parameters[["location"]], nrow = n_samples, ncol = K) + }else if(K == 1){ + samples <- matrix(rng(prior, n_samples, transform_factor_samples = FALSE), nrow = n_samples, ncol = K) + }else{ + samples <- rng(prior, n_samples, transform_factor_samples = FALSE) + } + + rownames(samples) <- NULL + colnames(samples) <- paste0(parameter,"[",1:K,"]") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.vector") + + return(samples) +} +.as_mixed_priors.factor <- function(prior, parameter, seed = NULL, n_samples = 10000){ + + # check input + check_list(prior, "prior") + check_char(parameter, "parameter") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + # check the prior levels + levels <- .get_prior_factor_levels(prior) + + # gather and check compatibility of prior distributions + prior_info <- list( + "levels" = .get_prior_factor_levels(prior), + "level_names" = .get_prior_factor_level_names(prior), + "interaction" = .is_prior_interaction(prior), + "treatment" = is.prior.treatment(prior), + "independent" = is.prior.independent(prior), + "orthonormal" = is.prior.orthonormal(prior), + "meandif" = is.prior.meandif(prior) + ) + + if(prior_info[["treatment"]]){ + + if(levels == 1){ + + samples <- .as_mixed_priors.simple(prior, parameter, seed, n_samples) + samples <- matrix(samples, ncol = 1) + + }else{ + + samples <- lapply(1:levels, function(i) .as_mixed_priors.simple(prior, paste0(parameter, "[", i, "]"), seed, n_samples)) + samples <- do.call(cbind, samples) + + } + + rownames(samples) <- NULL + colnames(samples) <- paste0(parameter,"[",prior_info$level_names[-1],"]") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.factor", "mixed_posteriors.vector") + + }else if(prior_info[["independent"]]){ + + if(levels == 1){ + + samples <- .as_mixed_priors.simple(prior, parameter, seed, n_samples) + samples <- matrix(samples, ncol = 1) + + }else{ + + samples <- lapply(1:levels, function(i) .as_mixed_priors.simple(prior, paste0(parameter, "[", i, "]"), seed, n_samples)) + samples <- do.call(cbind, samples) + + } + + rownames(samples) <- NULL + colnames(samples) <- paste0(parameter,"[",prior_info$level_names,"]") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.factor", "mixed_posteriors.vector") + + }else if(prior_info[["orthonormal"]] | prior_info[["meandif"]]){ + + prior$parameters[["K"]] <- levels + samples <- .as_mixed_priors.vector(prior, parameter, seed, n_samples) + class(samples) <- c(class(samples), "mixed_posteriors.factor") + + } + + attr(samples, "levels") <- prior_info[["levels"]] + attr(samples, "level_names") <- prior_info[["level_names"]] + attr(samples, "interaction") <- prior_info[["interaction"]] + attr(samples, "treatment") <- prior_info[["treatment"]] + attr(samples, "independent") <- prior_info[["independent"]] + attr(samples, "orthonormal") <- prior_info[["orthonormal"]] + attr(samples, "meandif") <- prior_info[["meandif"]] + + return(samples) +} +.as_mixed_priors.weightfunction <- function(prior, parameter, seed = NULL, n_samples = 10000){ + + # check input + check_list(prior, "prior") + check_char(parameter, "parameter") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + # do not set seed when sampling multiple prior for the same model -- they will end up completely correlated + if(!is.null(seed)){ + set.seed(seed) + } + + # obtain mapping for the weight coefficients + omega_mapping <- weightfunctions_mapping(list(prior)) + omega_cuts <- weightfunctions_mapping(list(prior), cuts_only = TRUE) + omega_names <- sapply(1:(length(omega_cuts)-1), function(i)paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) + + # prepare output objects + samples <- rng(prior, n_samples) + + rownames(samples) <- NULL + colnames(samples) <- omega_names + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.weightfunction") + + return(samples) +} +.as_mixed_priors.spike_and_slab <- function(prior, parameter, seed = NULL, n_samples = 10000){ + + # check input + check_list(prior, "prior") + check_char(parameter, "parameter") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + # do not set seed when sampling multiple prior for the same model -- they will end up completely correlated + if(!is.null(seed)){ + set.seed(seed) + } + + prior_variable <- prior[["variable"]] + prior_inclusion <- prior[["inclusion"]] + + inclusion <- stats::rbinom(n_samples, size = 1, prob = rng(prior_inclusion, n_samples)) + + if(is.prior.factor(prior_variable)){ + + samples <- .as_mixed_priors.factor(prior_variable, parameter, seed, n_samples) + + }else if(is.prior.simple(prior_variable)){ + + samples <- .as_mixed_priors.simple(prior_variable, parameter, seed, n_samples) + + } + + # merge with names and attributes + samples <- samples * inclusion + + class(samples) <- c(class(samples), "mixed_posteriors.spike_and_slab") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- inclusion + attr(samples, "prior_list") <- prior + + return(samples) +} +.as_mixed_priors.mixture <- function(prior, parameter, seed = NULL, n_samples = 10000){ + + # check input + check_list(prior, "prior") + check_char(parameter, "parameter") + check_real(seed, "seed", allow_NULL = TRUE) + check_int(n_samples, "n_samples") + + is_PET <- sapply(prior, is.prior.PET) + is_PEESE <- sapply(prior, is.prior.PEESE) + is_weightfunction <- sapply(prior, is.prior.weightfunction) + + if(any(is_PET | is_PEESE | is_weightfunction)){ + + stop("not implemented yet") # probably not needed + # samples <- NULL + # + # if(any(is_PET)){ + # samples <- cbind(samples, .as_mixed_posteriors.simple(fit, prior[is_PET][[1]], "PET")) + # } + # if(any(is_PEESE)){ + # samples <- cbind(.as_mixed_posteriors.simple(fit, prior[is_PEESE][[1]], "PEESE")) + # } + # if(any(is_weightfunction)){ + # # create a dummy prior with all the cuts + # dummy_prior <- #TODO: + # samples <- cbind(.as_mixed_posteriors.weightfunction(fit, dummy_prior, "omega")) + # } + # + # samples <- .as_mixed_posteriors.factor(fit, prior_variable, parameter) + # attr(samples, "models_ind") <- as.vector(model_samples[,paste0(parameter, "_indicator")]) + + }else{ + + is_simple <- sapply(prior, is.prior.simple) + is_factor <- sapply(prior, is.prior.factor) + + if(any(is_factor)){ + temp_samples <- .mix_priors.factor(prior, parameter = parameter, seed = seed, n_samples = n_samples) + }else{ + temp_samples <- .mix_priors.simple(prior, parameter = parameter, seed = seed, n_samples = n_samples) + } + + } + + # the samples parameters need to be randomly shuffled + # (the .mix_priors.XXX functions generate the samples model by model to keep bridge-sampling model-averaging consistent structure, + # this however does not apply to the spike an slab priors) + random_ind <- sample(n_samples) + if(is.null(dim(temp_samples))){ + samples <- temp_samples[random_ind] + }else{ + samples <- temp_samples[random_ind,,drop=FALSE] + } + attributes(samples) <- attributes(temp_samples) + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- attr(samples, "models_ind")[random_ind] + + # append classes and priors + class(samples) <- c(class(samples), "mixed_posteriors.mixture") + attr(samples, "prior_list") <- prior + + return(samples) +} #' @title Compute Savage-Dickey inclusion Bayes factors #' @@ -1067,8 +1544,7 @@ Savage_Dickey_BF <- function(posterior, null_hypothesis = 0, normal_approximatio #' @inheritParams marginal_posterior #' @inheritParams Savage_Dickey_BF #' -#' @return \code{mix_posteriors} returns a named list of mixed posterior -#' distributions (either a vector of matrix). +#' @return \code{marginal_inference} returns an object of class 'marginal_inference'. #' #' @seealso [ensemble_inference] [mix_posteriors] [BayesTools_ensemble_tables] #' @@ -1080,13 +1556,14 @@ marginal_inference <- function(model_list, marginal_parameters, parameters, is_n # check input (majority of the checks performed within mix_posteriors) check_list(model_list, "model_list") check_char(parameters, "parameters", check_length = FALSE) + check_char(marginal_parameters, "marginal_parameters", check_length = FALSE) check_list(is_null_list, "is_null_list", check_length = length(parameters)) if(!all(unlist(sapply(model_list, function(m) sapply(attr(m[["fit"]], "prior_list"), function(p) is.prior(p)))))) stop("model_list:priors must contain 'BayesTools' priors") # create one full model-averaged ensemble - averaged_posterior <- BayesTools::mix_posteriors( + averaged_posterior <- mix_posteriors( model_list = model_list, parameters = parameters, is_null_list = is_null_list, @@ -1111,7 +1588,7 @@ marginal_inference <- function(model_list, marginal_parameters, parameters, is_n # obtain model-averaged posterior conditional on including the parameter of interest # (different from individual conditionals) - temp_conditional_posterior <- BayesTools::mix_posteriors( + temp_conditional_posterior <- mix_posteriors( model_list = model_list[!is_null_list[[marginal_parameters[i]]]], parameters = parameters, is_null_list = lapply(is_null_list, function(l) l[!is_null_list[[marginal_parameters[i]]]]), @@ -1150,3 +1627,102 @@ marginal_inference <- function(model_list, marginal_parameters, parameters, is_n class(out) <- c(class(out), "marginal_inference") return(out) } + + +#' @title Model-average marginal posterior distributions and +#' marginal Bayes factors based on BayesTools JAGS model via \code{marginal_inference} +#' +#' @description Creates marginal model-averaged and conditional +#' posterior distributions based on a BayesTools JAGS model, vector of parameters, +#' formula, and a list of conditional specifications for each parameter. +#' Computes inclusion Bayes factors for each marginal estimate via a Savage-Dickey +#' density approximation. +#' +#' @param marginal_parameters parameters for which the the marginal summary +#' should be created +#' @param conditional_list list of conditional parameters for each marginal parameter +#' @param parameters all parameters included in the model_list that are +#' relevant for the formula (all of which need to have specification of +#' \code{is_null_list}) +#' @inheritParams as_mixed_posteriors +#' @inheritParams marginal_inference +#' @inheritParams Savage_Dickey_BF +#' +#' @return \code{as_marginal_inference} returns an object of class 'marginal_inference'. +#' +#' @seealso [marginal_inference] [as_mixed_posteriors] +#' +#' @export +as_marginal_inference <- function(model, marginal_parameters, parameters, conditional_list, conditional_rule, formula, + null_hypothesis = 0, normal_approximation = FALSE, + n_samples = 10000, silent = FALSE, force_plots = FALSE){ + + # check input (majority of the checks performed within mix_posteriors) + # check input + if(!inherits(model, "BayesTools_fit")) + stop("'model' must be a 'BayesTools_fit'") + check_char(parameters, "parameters", check_length = FALSE) + check_char(marginal_parameters, "marginal_parameters", check_length = FALSE) + check_list(conditional_list, "conditional_list", check_length = length(marginal_parameters)) + check_char(conditional_rule, "conditional_rule") + + priors <- attr(model, "prior_list") + + + # create one full model-averaged ensemble + averaged_posterior <- as_mixed_posteriors( + model = model, + parameters = parameters + ) + + # prepare output object + out <- list( + conditional = list(), + averaged = list(), + inference = list() + ) + + for(i in seq_along(marginal_parameters)){ + + check_char(conditional_list[[marginal_parameters[i]]], sprintf("conditional_list[[%1$s]]", marginal_parameters[i]), check_length = FALSE, allow_values = parameters, allow_NULL = TRUE) + + # obtain model-averaged posterior conditional on including the parameter of interest + # (different from individual conditionals) + temp_conditional_posterior <- as_mixed_posteriors( + model = model, + parameters = parameters, + conditional = conditional_list[[marginal_parameters[i]]], + conditional_rule = conditional_rule, + force_plots = force_plots + ) + + # compute the marginals + out[["averaged"]][[marginal_parameters[i]]] <- marginal_posterior( + samples = averaged_posterior, + parameter = marginal_parameters[i], + formula = formula, + prior_samples = TRUE, + n_samples = n_samples + ) + out[["conditional"]][[marginal_parameters[i]]] <- marginal_posterior( + samples = temp_conditional_posterior, + parameter = marginal_parameters[i], + formula = formula, + prior_samples = TRUE, + n_samples = n_samples + ) + + # and inclusion Bayes factor + out[["inference"]][[marginal_parameters[i]]] <- Savage_Dickey_BF( + posterior = out[["conditional"]][[marginal_parameters[i]]], + null_hypothesis = null_hypothesis, + normal_approximation = normal_approximation, + silent = silent + ) + } + + attr(out, "null_hypothesis") <- null_hypothesis + attr(out, "normal_approximation") <- normal_approximation + class(out) <- c(class(out), "marginal_inference") + return(out) +} diff --git a/R/model-averaging-plots.R b/R/model-averaging-plots.R index cd72e180..e74df5b8 100644 --- a/R/model-averaging-plots.R +++ b/R/model-averaging-plots.R @@ -366,6 +366,15 @@ plot_prior_list <- function(prior_list, plot_type = "base", prior_list <- prior_list[round(n_samples * mixing_prop) > 0] mixing_prop <- mixing_prop[round(n_samples * mixing_prop) > 0] + # replace non-weighfunctions from prior mixture feneration + if(any(!c(sapply(prior_list, is.prior.weightfunction) | sapply(prior_list, is.prior.none)))){ + for(i in seq_along(prior_list)){ + if(!(is.prior.weightfunction(prior_list[[i]]) | is.prior.none(prior_list[[i]]))){ + prior_list[[i]] <- prior_none(prior_weights = prior_weights[i]) + } + } + } + # get the samples samples_list <- list() for(i in seq_along(prior_list)){ @@ -487,6 +496,29 @@ plot_prior_list <- function(prior_list, plot_type = "base", } .plot_data_prior_list.simple <- function(prior_list, x_seq, x_range, x_range_quant, n_points, n_samples, force_samples, individual, transformation, transformation_arguments, transformation_settings){ + + # dispatching for spike and slab priors + if(is.prior.spike_and_slab(prior_list)){ + + prior_inclusion <- prior_list[["inclusion"]] + prior_variable <- prior_list[["variable"]] + + if(mean(prior_inclusion) < 1 && mean(prior_inclusion) > 0){ + # create a dummy list for the simple mixture + prior_null <- prior("spike", list(0), prior_weights = 1-mean(prior_inclusion)) + prior_variable[["prior_weights"]] <- mean(prior_inclusion) + + prior_list <- list( + prior_variable, + prior_null + ) + }else if(mean(prior_inclusion) >= 1){ + prior_list <- list(prior_variable) + }else if(mean(prior_inclusion) <= 0){ + prior_list <- list(prior("spike", list(0))) + } + } + # join the same priors prior_list <- .simplify_prior_list(prior_list) @@ -608,6 +640,10 @@ plot_prior_list <- function(prior_list, plot_type = "base", .simplify_prior_list <- function(prior_list){ + if(is.prior.mixture(prior_list)){ + class(prior_list) <- NULL + } + # return the input with fewer than 2 priors if(length(prior_list) < 2){ return(prior_list) @@ -922,7 +958,16 @@ plot_posterior <- function(samples, parameter, plot_type = "base", prior = FALSE # add priors, if requested if(prior){ - prior_list <- attr(samples[[parameter]], "prior_list") + + # extract the correct weightfunction samples + if(!is.null(samples[[parameter]])){ + prior_list <- attr(samples[[parameter]], "prior_list") + }else if(!is.null(samples[["bias"]])){ + prior_list <- attr(samples[["bias"]], "prior_list") + }else{ + stop("No 'omega' or 'bias' samples found.") + } + prior_list <- .simplify_prior_list(prior_list) plot_data_prior <- .plot_data_prior_list.weightfunction(prior_list, x_seq = NULL, x_range = xlim, x_range_quant = NULL, n_points = n_points, n_samples = n_samples) @@ -1274,6 +1319,7 @@ plot_posterior <- function(samples, parameter, plot_type = "base", prior = FALSE .plot_data_samples.PETPEESE <- function(samples, x_seq, x_range, x_range_quant, n_points, transformation, transformation_arguments, transformation_settings){ check_list(samples, "samples") + if(is.null(samples[["PET"]]) & is.null(samples[["PEESE"]])) stop("At least one 'PET' or 'PEESE' model needs to be specified.") if(is.null(samples[["mu"]])) @@ -1335,7 +1381,14 @@ plot_posterior <- function(samples, parameter, plot_type = "base", prior = FALSE .plot_data_samples.weightfunction <- function(samples, x_seq, x_range, x_range_quant, n_points){ check_list(samples, "samples", check_names = "omega", allow_other = TRUE) - samples <- samples[["omega"]] + if(!is.null(samples[["omega"]])){ + samples <- samples[["omega"]] + }else if(!is.null(samples[["bias"]])){ + samples <- samples[["bias"]] + }else{ + stop("No 'omega' or 'bias' samples found.") + } + prior_list <- attr(samples, "prior_list") # get the plotting range diff --git a/R/model-averaging.R b/R/model-averaging.R index 165978fb..1d62ae65 100644 --- a/R/model-averaging.R +++ b/R/model-averaging.R @@ -170,7 +170,7 @@ models_inference <- function(model_list){ #' @return \code{mix_posteriors} returns a named list of mixed posterior #' distributions (either a vector of matrix). #' -#' @seealso [ensemble_inference] [BayesTools_ensemble_tables] +#' @seealso [ensemble_inference] [BayesTools_ensemble_tables] [as_mixed_posteriors] #' #' @name mix_posteriors #' @export @@ -289,6 +289,7 @@ mix_posteriors <- function(model_list, parameters, is_null_list, conditional = F } + class(out) <- c(class(out), "mixed_posteriors") return(out) } @@ -673,6 +674,478 @@ mix_posteriors <- function(model_list, parameters, is_null_list, conditional = F return(samples) } +#' @title Export BayesTools JAGS model posterior distribution as model-average posterior distributions via \code{mix_posteriors} +#' +#' @description Creates a model-averages posterior distributions on a single +#' model that allows mimicking the [mix_posteriors] functionality. This function +#' is useful when the model-averaged ensemble is based on [prior_spike_and_slab] +#' or [prior_mixture] priors - the model-averaging is done within the model. +#' +#' @param model model fit via the [JAGS_fit] function +#' @param conditional a character vector of parameters to be conditioned on +#' @param conditional_rule a character string specifying the rule for conditioning. +#' Either "AND" or "OR". Defaults to "AND". +#' @param force_plots temporal argument allowing to generate conditional posterior samples +#' suitable for prior and posterior plots. Only available when conditioning on a +#' single parameter. +#' @inheritParams ensemble_inference +#' @inheritParams mix_posteriors +#' +#' @return \code{as_mix_posteriors} returns a named list of mixed posterior +#' distributions (either a vector of matrix). +#' +#' @seealso [mix_posteriors] +#' +#' @name as_mixed_posteriors +#' @export +as_mixed_posteriors <- function(model, parameters, conditional = NULL, conditional_rule = "AND", force_plots = FALSE){ + + # check input + if(!inherits(model, "BayesTools_fit")) + stop("'model' must be a 'BayesTools_fit'") + check_char(parameters, "parameters", check_length = FALSE) + check_char(conditional, "conditional", check_length = FALSE, allow_values = c(parameters, "PET", "PEESE", "PETPEESE", "omega"), allow_NULL = TRUE) + check_char(conditional_rule, "conditional_rule", allow_values = c("AND", "OR")) + + # extract the list of priors + priors <- attr(model, "prior_list") + + # extract the samples + model_samples <- suppressWarnings(coda::as.mcmc(model)) + if(!is.matrix(model_samples)){ + # deal with automatic coercion into a vector in case of a single predictor + model_samples <- matrix(model_samples, ncol = 1) + colnames(model_samples) <- model$monitor + } + + # apply conditioning + if(length(conditional) > 0){ + + # subset the posterior distribution + conditioning_samples <- do.call(cbind, lapply(conditional, function(parameter){ + + # special cases for PET / PEESE / PET-PEESE / weightfunctions + if(parameter == "PET" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_PET <- sapply(priors[["bias"]], is.prior.PET) + return(model_samples[, "bias_indicator"] %in% which(is_PET)) + } + if(parameter == "PEESE" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_PEESE <- sapply(priors[["bias"]], is.prior.PEESE) + return(model_samples[, "bias_indicator"] %in% which(is_PEESE)) + } + if(parameter == "PETPEESE" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_PET <- sapply(priors[["bias"]], is.prior.PET) + is_PEESE <- sapply(priors[["bias"]], is.prior.PEESE) + return(model_samples[, "bias_indicator"] %in% which(is_PET | is_PEESE)) + } + if(parameter == "omega" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_weightfunction <- sapply(priors[["bias"]], is.prior.weightfunction) + return(model_samples[, "bias_indicator"] %in% which(is_weightfunction)) + } + + # normal cases + temp_prior <- priors[[parameter]] + + if(is.prior.spike_and_slab(temp_prior)){ + + return(model_samples[,paste0(parameter, "_indicator")] == 1) + + }else if(is.prior.mixture(temp_prior)){ + + components <- attr(temp_prior, "components") + if(!all(components %in% c("null", "alternative"))) + stop("conditional mixture posterior distributions are available only for 'null' and 'alternative' components") + + return(model_samples[,paste0(parameter, "_indicator")] %in% which(components == "alternative")) + + }else{ + + warning(sprintf("The parameter '%s' is not a conditional parameter.", parameter), call. = FALSE, immediate. = TRUE) + return(rep(TRUE, nrow(model_samples))) + + } + })) + conditioning_samples <- apply(conditioning_samples, 1, ifelse(conditional_rule == "AND", all, any)) + + if(sum(conditioning_samples) == 0){ + warning("No samples left after conditioning.", call. = FALSE, immediate. = TRUE) + return(list()) + } + + + model_samples <- model_samples[conditioning_samples,,drop=FALSE] + + # set prior weights to 0 for null distributions + # TODO: this needs to be implemented for enabling of the conditional mixture posterior distributions when more than one components is present + # (e.g., conditional marginal and posterior plots) + # the current workaround is suitable only for a single parameters (to produce averaged prior and posterior plots) + if(length(conditional) == 1 && length(parameters) == 1 && conditional == parameters && force_plots){ + + # special cases for PET / PEESE / PET-PEESE / weightfunctions + if(conditional == "PET" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_PET <- sapply(priors[["bias"]], is.prior.PET) + for(i in seq(along = is_PET)){ + if(!is_PET[i]){ + priors[[parameters]][[i]][["prior_weights"]] <- 0 + } + } + }else if(conditional == "PEESE" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + for(i in seq(along = is_PEESE)){ + if(!is_PEESE[i]){ + priors[[parameters]][[i]][["prior_weights"]] <- 0 + } + } + }else if(conditional == "PETPEESE" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_PET <- sapply(priors[["bias"]], is.prior.PET) + is_PEESE <- sapply(priors[["bias"]], is.prior.PEESE) + for(i in seq(along = is_PET)){ + if(!(is_PET[i] || is_PEESE[i])){ + priors[[parameters]][[i]][["prior_weights"]] <- 0 + } + } + }else if(conditional == "omega" && !is.null(priors[["bias"]]) && is.prior.mixture(priors[["bias"]])){ + is_weightfunction <- sapply(priors[["bias"]], is.prior.weightfunction) + for(i in seq(along = is_weightfunction)){ + if(!is_weightfunction[i]){ + priors[[parameters]][[i]][["prior_weights"]] <- 0 + } + } + }else if(is.prior.spike_and_slab(priors[[parameters]])){ + priors[[parameters]][["inclusion"]] <- prior("spike", list(1)) + }else if(is.prior.mixture(priors[[parameters]])){ + + components <- attr(priors[[parameters]], "components") + + attr(priors[[parameters]], "prior_weights")[which(components == "null")] <- 0 + for(i in seq(along = components)){ + if(components[i] == "null"){ + priors[[parameters]][[i]][["prior_weights"]] <- 0 + } + } + } + } + } + + + out <- list() + + for(p in seq_along(parameters)){ + + # prepare parameter specific values + temp_parameter <- parameters[p] + temp_prior <- priors[[temp_parameter]] + + if(is.prior.spike_and_slab(temp_prior)){ + # spike and slab priors + out[[temp_parameter]] <- .as_mixed_posteriors.spike_and_slab(model_samples, temp_prior, temp_parameter) + + }else if(is.prior.mixture(temp_prior)){ + # mixture priors + out[[temp_parameter]] <- .as_mixed_posteriors.mixture(model_samples, temp_prior, temp_parameter, conditional) + + }else if(is.prior.weightfunction(temp_prior)){ + # weight functions + out[[temp_parameter]] <- .as_mixed_posteriors.weightfunction(model_samples, temp_prior, temp_parameter) + + }else if(is.prior.factor(temp_prior)){ + # factor priors + out[[temp_parameter]] <- .as_mixed_posteriors.factor(model_samples, temp_prior, temp_parameter) + + }else if(is.prior.vector(temp_prior)){ + # vector priors + out[[temp_parameter]] <- .as_mixed_posteriors.vector(model_samples, temp_prior, temp_parameter) + + }else if(is.prior.simple(temp_prior)){ + # simple priors + out[[temp_parameter]] <- .as_mixed_posteriors.simple(model_samples, temp_prior, temp_parameter) + + }else{ + stop("The posterior samples cannot be mixed: unsupported prior distributions.") + } + + # add formula relevant information + if(!is.null(attr(temp_prior, which = "parameter"))){ + class(out[[temp_parameter]]) <- c(class(out[[temp_parameter]]), "mixed_posteriors.formula") + attr(out[[temp_parameter]], "formula_parameter") <- attr(temp_prior, which = "parameter") + } + + # add conditioning information + attr(out[[temp_parameter]], "conditional") <- conditional + attr(out[[temp_parameter]], "conditional_rule") <- conditional_rule + + } + + attr(out, "prior_list") <- priors + attr(out, "conditional") <- conditional + attr(out, "conditional_rule") <- conditional_rule + class(out) <- c(class(out), "as_mixed_posteriors", "mixed_posteriors") + return(out) +} + +.as_mixed_posteriors.simple <- function(model_samples, prior, parameter){ + + # check input + check_char(parameter, "parameter", check_length = FALSE) + + # gather information about the prior distribution + prior_info <- list( + "interaction" = .is_prior_interaction(prior), + "interaction_terms" = attr(prior, "interaction_terms") + ) + + # prepare output objects + samples <- model_samples[, parameter] + + # format the output + samples <- unname(samples) + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + attr(samples, "interaction") <- if(length(prior_info) == 0) FALSE else prior_info[["interaction"]] + attr(samples, "interaction_terms") <- prior_info[["interaction_terms"]] + class(samples) <- c("mixed_posteriors", "mixed_posteriors.simple") + + return(samples) +} +.as_mixed_posteriors.vector <- function(model_samples, prior, parameter){ + + # check input + check_char(parameter, "parameter", check_length = FALSE) + + # gather information about the prior distribution + K <- prior$parameter[["K"]] + if(length(K) != 1) + stop("all vector prior must be of the same length") + + # prepare output objects + if(K == 1){ + samples <- model_samples[, parameter, drop = FALSE] + }else{ + samples <- model_samples[, paste0(parameter,"[",1:K,"]"), drop = FALSE] + } + + rownames(samples) <- NULL + colnames(samples) <- paste0(parameter,"[",1:K,"]") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.vector") + + return(samples) +} +.as_mixed_posteriors.factor <- function(model_samples, prior, parameter){ + + # check input + check_char(parameter, "parameter", check_length = FALSE) + + # gather information about the prior distribution + prior_info <- list( + "levels" = .get_prior_factor_levels(prior), + "level_names" = .get_prior_factor_level_names(prior), + "interaction" = .is_prior_interaction(prior), + "interaction_terms" = attr(prior, "interaction_terms"), + "treatment" = is.prior.treatment(prior), + "independent" = is.prior.independent(prior), + "orthonormal" = is.prior.orthonormal(prior), + "meandif" = is.prior.meandif(prior) + ) + + + if(prior_info[["treatment"]]){ + + if(prior_info[["levels"]] == 1){ + + samples <- .as_mixed_posteriors.simple(model_samples, prior, parameter) + samples <- matrix(samples, ncol = 1) + + }else{ + + samples <- lapply(1:prior_info[["levels"]], function(i) .as_mixed_posteriors.simple(model_samples, prior, paste0(parameter, "[", i, "]"))) + samples <- do.call(cbind, samples) + + } + + rownames(samples) <- NULL + colnames(samples) <- paste0(parameter,"[",prior_info[["level_names"]][-1],"]") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.factor", "mixed_posteriors.vector") + + }else if(prior_info[["independent"]]){ + + if(prior_info[["levels"]] == 1){ + + samples <- .as_mixed_posteriors.simple(model_samples, prior, parameter) + samples <- matrix(samples, ncol = 1) + + }else{ + + samples <- lapply(1:prior_info[["levels"]], function(i) .as_mixed_posteriors.simple(model_samples, prior, paste0(parameter, "[", i, "]"))) + samples <- do.call(cbind, samples) + + } + + rownames(samples) <- NULL + colnames(samples) <- paste0(parameter,"[",prior_info[["level_names"]],"]") + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.factor", "mixed_posteriors.vector") + + }else if(prior_info[["orthonormal"]] | prior_info[["meandif"]]){ + + prior$parameter[["K"]] <- prior_info[["levels"]] + samples <- .as_mixed_posteriors.vector(model_samples, prior, parameter) + class(samples) <- c(class(samples), "mixed_posteriors.factor") + + } + + attr(samples, "levels") <- prior_info[["levels"]] + attr(samples, "level_names") <- prior_info[["level_names"]] + attr(samples, "interaction") <- if(length(prior_info) == 0) FALSE else prior_info[["interaction"]] + attr(samples, "interaction_terms") <- prior_info[["interaction_terms"]] + attr(samples, "treatment") <- prior_info[["treatment"]] + attr(samples, "independent") <- prior_info[["independent"]] + attr(samples, "orthonormal") <- prior_info[["orthonormal"]] + attr(samples, "meandif") <- prior_info[["meandif"]] + + return(samples) +} +.as_mixed_posteriors.weightfunction <- function(model_samples, prior, parameter){ + + # check input + check_char(parameter, "parameter", check_length = FALSE) + + # obtain mapping for the weight coefficients + omega_mapping <- weightfunctions_mapping(list(prior)) + omega_cuts <- weightfunctions_mapping(list(prior), cuts_only = TRUE) + omega_names <- sapply(1:(length(omega_cuts)-1), function(i) paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) + + # prepare output objects + samples <- model_samples[, sapply(1:(length(omega_cuts)-1), function(i) paste0("omega[",i,"]"))] + + rownames(samples) <- NULL + colnames(samples) <- omega_names + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- FALSE + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.weightfunction") + + return(samples) +} +.as_mixed_posteriors.spike_and_slab <- function(model_samples, prior, parameter){ + + # check input + check_char(parameter, "parameter", check_length = FALSE) + + prior_variable <- prior[["variable"]] + + # prepare output objects + if(is.prior.factor(prior_variable)){ + + samples <- .as_mixed_posteriors.factor(model_samples, prior_variable, parameter) + attr(samples, "models_ind") <- as.vector(model_samples[,paste0(parameter, "_indicator")]) + + }else if(is.prior.simple(prior_variable)){ + + samples <- .as_mixed_posteriors.simple(model_samples, prior_variable, parameter) + attr(samples, "models_ind") <- as.vector(model_samples[,paste0(parameter, "_indicator")]) + + } + + class(samples) <- c("mixed_posteriors.spike_and_slab", class(samples)) + attr(samples, "prior_list") <- prior + + return(samples) +} +.as_mixed_posteriors.mixture <- function(model_samples, prior, parameter, conditional){ + + # check input + check_char(parameter, "parameter", check_length = FALSE) + + + # prepare output objects + if(inherits(prior, "prior.bias_mixture")){ + + is_PET <- sapply(prior, is.prior.PET) + is_PEESE <- sapply(prior, is.prior.PEESE) + is_weightfunction <- sapply(prior, is.prior.weightfunction) + + # prepare weightfunction parameter names + if(any(is_weightfunction)){ + omega_mapping <- weightfunctions_mapping(prior[is_weightfunction], one_sided = TRUE) + omega_cuts <- weightfunctions_mapping(prior[is_weightfunction], cuts_only = TRUE, one_sided = TRUE) + omega_names <- sapply(1:(length(omega_cuts)-1), function(i) paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) + omega_par <- rev(sapply(1:(length(omega_cuts)-1), function(i) paste0("omega[",i,"]"))) + } + + # deal with conditional parameters + if(length(conditional) > 0 && any(c("PET", "PEESE", "PETPEESE", "omega") %in% conditional)){ + + if("omega" %in% conditional){ + out_names <- omega_names + par_names <- omega_par + }else if("PETPEESE" %in% conditional){ + out_names <- par_names <- c("PET", "PEESE") + }else if("PET" %in% conditional){ + out_names <- par_names <- "PET" + }else if("PEESE" %in% conditional){ + out_names <- par_names <- "PEESE" + } + + }else{ + + out_names <- NULL + par_names <- NULL + + if(any(is_weightfunction)){ + out_names <- c(out_names, omega_names) + par_names <- c(par_names, omega_par) + } + if(any(is_PET)){ + out_names <- c(out_names, "PET") + par_names <- c(par_names, "PET") + } + if(any(is_PEESE)){ + out_names <- c(out_names, "PEESE") + par_names <- c(par_names, "PEESE") + } + } + + # select samples + samples <- model_samples[, par_names,drop=FALSE] + indicator <- model_samples[,paste0(parameter, "_indicator")] + + rownames(samples) <- NULL + colnames(samples) <- out_names + attr(samples, "sample_ind") <- FALSE + attr(samples, "models_ind") <- as.vector(indicator) + attr(samples, "parameter") <- parameter + attr(samples, "prior_list") <- prior + class(samples) <- c("mixed_posteriors", "mixed_posteriors.bias") + + }else{ + + if(inherits(prior, "prior.simple_mixture")){ + samples <- .as_mixed_posteriors.simple(model_samples, prior, parameter) + }else if(inherits(prior, "prior.factor_mixture")){ + samples <- .as_mixed_posteriors.factor(model_samples, prior, parameter) + } + attr(samples, "models_ind") <- as.vector(model_samples[,paste0(parameter, "_indicator")]) + + } + + class(samples) <- c("mixed_posteriors.mixture", class(samples)) + attr(samples, "prior_list") <- prior + + return(samples) +} #' @title Compute inclusion Bayes factors #' @@ -759,19 +1232,20 @@ inclusion_BF <- function(prior_probs, post_probs, margliks, is_null){ #' #' @param prior_list list of prior distributions #' @param cuts_only whether only p-value cuts should be returned +#' @param one_sided force one-sided output #' #' @return \code{weightfunctions_mapping} returns a list of indices #' mapping the publication weights omega from the individual weightfunctions #' into a joint weightfunction. #' #' @export -weightfunctions_mapping <- function(prior_list, cuts_only = FALSE){ +weightfunctions_mapping <- function(prior_list, cuts_only = FALSE, one_sided = FALSE){ # check input if(!all(sapply(prior_list, is.prior.weightfunction) | sapply(prior_list, is.prior.point) | sapply(prior_list, is.prior.none))) stop("'priors' must be a list of weightfunction priors distributions") check_bool(cuts_only, "cuts_only") - + check_bool(one_sided, "one_sided") # extract cuts and types priors_cuts <- lapply(prior_list, function(prior)rev(prior[["parameters"]][["steps"]])) @@ -780,7 +1254,7 @@ weightfunctions_mapping <- function(prior_list, cuts_only = FALSE){ # get new cutpoint appropriate cut-points priors_cuts_new <- priors_cuts - if(any(grepl("one.sided", priors_type))){ + if(one_sided || any(grepl("one.sided", priors_type))){ # translate two.sided into one.sided for(p in seq_along(priors_type)){ @@ -809,7 +1283,7 @@ weightfunctions_mapping <- function(prior_list, cuts_only = FALSE){ l = c(0, priors_cuts_new[[p]]), u = c(priors_cuts_new[[p]], 1)) - if(any(grepl("one.sided", priors_type))){ + if(one_sided || any(grepl("one.sided", priors_type))){ if(grepl("two.sided", priors_type[p])){ omega_ind[[p]] <- rev(c( (length(priors_cuts[[p]]) + 1):2, 1:(length(priors_cuts[[p]]) + 1) )) }else if(grepl("one.sided", priors_type[p])){ diff --git a/R/priors-plot.R b/R/priors-plot.R index 895cf0c6..109d6971 100644 --- a/R/priors-plot.R +++ b/R/priors-plot.R @@ -55,6 +55,14 @@ plot.prior <- function(x, plot_type = "base", check_bool(rescale_x, "rescale_x") check_int(show_figures, "show_figures", allow_NULL = TRUE) + if(is.prior.mixture(x)){ + class(x) <- NULL + return(plot_prior_list(x, plot_type = plot_type, x_seq = x_seq, xlim = xlim, x_range_quant = x_range_quant, n_points = n_points, + n_samples = n_samples, force_samples = force_samples, transformation = transformation, + transformation_arguments = transformation_arguments, transformation_settings = transformation_settings, + show_figures = show_figures, individual = individual, rescale_x = rescale_x, par_name = par_name, ...)) + } + # get the plotting data if(is.null(xlim) & is.null(x_seq)){ @@ -732,6 +740,15 @@ lines.prior <- function(x, xlim = NULL, x_seq = NULL, x_range_quant = NULL, n_po check_int(show_parameter, "show_parameter", allow_NULL = TRUE) check_real(scale_y2, "scale_y2", lower = 0) + if(is.prior.mixture(x)){ + class(x) <- NULL + return(lines_prior_list(x, xlim = xlim, x_seq = x_seq, x_range_quant = x_range_quant, n_points = n_points, + n_samples = n_samples, force_samples = force_samples, + transformation = transformation, transformation_arguments = transformation_arguments, transformation_settings = transformation_settings, + rescale_x = rescale_x, scale_y2 = scale_y2, ...)) + } + + # get the plotting data if(is.null(xlim) & is.null(x_seq)){ @@ -776,6 +793,12 @@ lines.prior <- function(x, xlim = NULL, x_seq = NULL, x_range_quant = NULL, n_po return(invisible()) } + # plot spike and slab prior + if(is.prior.spike_and_slab(x)){ + .lines.prior.spike_and_slab(plot_data, ...) + return(invisible()) + } + # point prior plots if(is.prior.point(x)){ .lines.prior.point(plot_data, scale_y2 = scale_y2, ...) @@ -794,12 +817,6 @@ lines.prior <- function(x, xlim = NULL, x_seq = NULL, x_range_quant = NULL, n_po return(invisible()) } - # plot spike and slab prior - if(is.prior.spike_and_slab(x)){ - .lines.prior.spike_and_slab(plot_data, ...) - return(invisible()) - } - # default prior plots if(is.prior.simple(x)){ .lines.prior.simple(plot_data, ...) @@ -831,6 +848,13 @@ geom_prior <- function(x, xlim = NULL, x_seq = NULL, x_range_quant = NULL, n_po check_int(show_parameter, "show_parameter", allow_NULL = TRUE) check_real(scale_y2, "scale_y2", lower = 0) + if(is.prior.mixture(x)){ + class(x) <- NULL + return(geom_prior_list(x, xlim = xlim, x_seq = x_seq, x_range_quant = x_range_quant, n_points = n_points, + n_samples = n_samples, force_samples = force_samples, + transformation = transformation, transformation_arguments = transformation_arguments, transformation_settings = transformation_settings, + rescale_x = rescale_x, scale_y2 = scale_y2, ...)) + } # get the plotting data if(is.null(xlim) & is.null(x_seq)){ @@ -873,6 +897,13 @@ geom_prior <- function(x, xlim = NULL, x_seq = NULL, x_range_quant = NULL, n_po } + # plot spike and slab prior + if(is.prior.spike_and_slab(x)){ + geom <- .geom_prior.spike_and_slab(plot_data, ...) + return(geom) + } + + # plot point prior if(is.prior.point(x)){ geom <- .geom_prior.point(plot_data, ...) @@ -894,13 +925,6 @@ geom_prior <- function(x, xlim = NULL, x_seq = NULL, x_range_quant = NULL, n_po } - # plot spike and slab prior - if(is.prior.spike_and_slab(x)){ - geom <- .geom_prior.spike_and_slab(plot_data, ...) - return(geom) - } - - # default prior plots if(is.prior.simple(x)){ geom <- .geom_prior.simple(plot_data, ...) diff --git a/R/priors-print.R b/R/priors-print.R index dfc14800..dd3706d0 100644 --- a/R/priors-print.R +++ b/R/priors-print.R @@ -49,6 +49,13 @@ print.prior <- function(x, short_name = FALSE, parameter_names = FALSE, plot = F silent <- TRUE } + dots <- list(...) + if(is.null(dots[["inline"]])){ + inline <- FALSE + }else{ + inline <- dots[["inline"]] + check_bool(inline, "inline") + } if(is.prior.none(x)){ output <- .print.prior.none(x, short_name, parameter_names, plot, digits_estimates, silent) @@ -58,6 +65,8 @@ print.prior <- function(x, short_name = FALSE, parameter_names = FALSE, plot = F output <- .print.prior.weightfunction(x, short_name, parameter_names, plot, digits_estimates, silent) }else if(is.prior.spike_and_slab(x)){ output <- .print.prior.spike_and_slab(x, short_name, parameter_names, plot, digits_estimates, silent) + }else if(is.prior.mixture(x)){ + output <- .print.prior.mixture(x, short_name, parameter_names, plot, digits_estimates, silent, inline) } @@ -321,3 +330,40 @@ print.prior <- function(x, short_name = FALSE, parameter_names = FALSE, plot = F return(output) } +.print.prior.mixture <- function(x, short_name, parameter_names, plot, digits_estimates, silent, inline){ + + prior_names <- lapply(x, function(p){ + print(p, short_name, parameter_names, plot, digits_estimates, silent = TRUE) + }) + + prior_weights <- attr(x, "prior_weights") + prior_weights <- paste0("(", round(prior_weights, digits_estimates), "/", round(sum(prior_weights), digits_estimates), ")") + + prior_components <- attr(x, "components") + if(all(prior_components %in% c("null", "alternative"))){ + prior_components <- sort(prior_components) + } + + if(!plot){ + + output <- NULL + + # inline printing for summary tables + if(inline){ + output <- paste0(paste0(prior_weights, " * ", prior_names), collapse = " + ") + }else{ + for(component in unique(prior_components)){ + output <- paste0(output, component, ":\n") + for(i in seq_along(prior_components)[prior_components == component]){ + output <- paste0(output, " ", prior_weights[i], " * ", prior_names[[i]], "\n") + } + } + } + + }else{ + output <- Map(function(weight, prior) bquote(.(as.name(weight))~"*"~.(prior)), prior_weights, prior_names) + output <- Reduce(function(x, y) bquote(.(x)~+~.(y)), output) + } + + return(output) +} diff --git a/R/priors-tools.R b/R/priors-tools.R index e71bb7ca..045a549b 100644 --- a/R/priors-tools.R +++ b/R/priors-tools.R @@ -196,6 +196,41 @@ return(attr(prior, "level_names")) } } +.get_prior_factor_list_type <- function(prior_list){ + + priors_type <- do.call(rbind, lapply(prior_list, function(p) { + if(is.prior.point(p) | is.prior.none(p)){ + return(data.frame( + "treatment" = NA, + "independent" = NA, + "orthonormal" = NA, + "meandif" = NA, + "K" = NA + )) + }else{ + return(data.frame( + "treatment" = is.prior.treatment(p), + "independent" = is.prior.independent(p), + "orthonormal" = is.prior.orthonormal(p), + "meandif" = is.prior.meandif(p), + "K" = if(!is.null(p[["parameters"]][["K"]])) p[["parameters"]][["K"]] else NA + )) + } + })) + priors_type <- priors_type[!apply(priors_type, 1, function(x) all(is.na(x))),] + priors_type <- unique(priors_type) + + if(nrow(priors_type) > 1) + stop("The prior_list must contain only one type of factor priors.") + + class_type <- unlist(priors_type[-ncol(priors_type)]) + class_type <- names(class_type)[which(class_type)] + + return(list( + "class" = paste0("prior.", class_type), + "K" = priors_type[["K"]] + )) +} .is_prior_interaction <- function(prior){ if(is.null(attr(prior, "interaction"))){ return(FALSE) @@ -244,6 +279,7 @@ #' @export is.prior.treatment #' @export is.prior.independent #' @export is.prior.spike_and_slab +#' @export is.prior.mixture #' @name is.prior NULL @@ -307,10 +343,60 @@ is.prior.spike_and_slab <- function(x){ is.prior.meandif <- function(x){ inherits(x, "prior.meandif") } +#' @rdname is.prior +is.prior.mixture <- function(x){ + inherits(x, "prior.mixture") +} .check_prior <- function(prior, name = "prior"){ + if(!is.prior(prior)) - stop(paste0("The '", name, "' argument must be a valid prior object.")) + stop(paste0("The '", name, "' argument must be a valid prior object."), call. = FALSE) + + return() +} +.check_prior_list <- function(prior_list, name = "prior_list", check_length = 0, allow_NULL = FALSE, + allow_prior.point = TRUE, allow_prior.simple = TRUE, allow_prior.discrete = TRUE, allow_prior.vector = TRUE, + allow_prior.PET = TRUE, allow_prior.PEESE = TRUE, allow_prior.weightfunction = TRUE, allow_prior.factor = TRUE){ + + check_list(prior_list, name, check_length = check_length, allow_other = FALSE, allow_NULL = allow_NULL) + + if(allow_NULL && is.null(prior_list) || length(prior_list) == 0) + return() + + for(i in seq_along(prior_list)){ + .check_prior(prior_list[[i]], paste0(name, "[[", i, "]] argument must be a prior distribution.")) + + if(!allow_prior.point && is.prior.point(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain point priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.simple && is.prior.simple(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain simple priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.discrete && is.prior.discrete(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain discrete priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.vector && is.prior.vector(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain vector priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.PET && is.prior.PET(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain PET priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.PEESE && is.prior.PEESE(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain PEESE priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.weightfunction && is.prior.weightfunction(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain weightfunction priors (element [[", i, "]])."), call. = FALSE) + + if(!allow_prior.factor && is.prior.factor(prior_list[[i]])) + stop(paste0("The '", name, "' argument must not contain factor priors (element [[", i, "]])."), call. = FALSE) + + if(is.prior.mixture(prior_list[[i]])){ + stop(paste0("The '", name, "' argument must not contain mixture priors (element [[", i, "]])."), call. = FALSE) + } + } + + return() } diff --git a/R/priors.R b/R/priors.R index c7521bc6..1e84fcb3 100644 --- a/R/priors.R +++ b/R/priors.R @@ -169,6 +169,14 @@ prior_none <- function(prior_weights = 1){ #' parameters, and sets the model priors odds to the product of #' its prior distributions. #' +#' @details Constrained cases of weight functions can be specified by adding +#' ".fixed" after the distribution name, i.e., \code{"two.sided.fixed"} and +#' \code{"one.sided.fixed"}. In these cases, the functions are specified using +#' \code{steps} and \code{omega} parameters, where the \code{omega} parameter +#' is a vector of weights that corresponds to the relative publication probability +#' (i.e., no parameters are estimated). +#' +#' #' @examples #' p1 <- prior_weightfunction("one-sided", parameters = list(steps = c(.05, .10), alpha = c(1, 1, 1))) #' @@ -404,12 +412,123 @@ prior_spike_and_slab <- function(prior_parameter, inclusion = prior_inclusion ) - class(output) <- c("prior", "prior.spike_and_slab") + # distinguish normal and factor prior distributions + if(is.prior.factor(prior_parameter)){ + + # obtain and store the contrast type + priors_type <- .get_prior_factor_list_type(list(prior_parameter)) + + attr(prior_parameter, "K") <- priors_type[["K"]] + class(output) <- c("prior", "prior.spike_and_slab", "prior.factor_spike_and_slab", priors_type[["class"]]) + + }else if(is.prior.simple(prior_parameter)){ + class(output) <- c("prior", "prior.spike_and_slab", "prior.simple_spike_and_slab") + }else{ + stop("The 'prior_parameter' must be either a simple or factor prior distribution.") + } return(output) } +#' @title Creates a mixture of prior distributions +#' @description \code{prior_mixture} creates a mixture of prior distributions. +#' This is a more generic version of the \code{prior_spike_and_slab} function. +#' +#' @param prior_list a list of prior distributions to be mixed. +#' @param is_null a logical vector indicating which of the prior distributions +#' should be considered as a null distribution. Defaults to \code{rep(FALSE, length(prior_list))}. +#' @param components a character vector indicating which of the prior distributions +#' belong to the same mixture component (this is an alternative specification to the \code{is_null} argument). +#' Defaults to \code{NULL} (i.e., \code{is_null} is used. +#' +#' @seealso [prior()] +#' @export +prior_mixture <- function(prior_list, is_null = rep(FALSE, length(prior_list)), components = NULL){ + + .check_prior_list(prior_list) + check_bool(is_null, "is_null", check_length = length(prior_list), allow_NULL = TRUE) + check_char(components, "components", check_length = length(prior_list), allow_NULL = TRUE) + if(is.null(is_null) && is.null(components)) + stop("Either 'is_null' or 'components' must be specified.") + + if(is.null(components)){ + components <- ifelse(is_null, "null", "alternative") + } + + for(i in seq_along(prior_list)){ + attr(prior_list[[i]], "component") <- components[i] + } + + + # distinguish normal, factor, and publication bias mixture priors + if(any(sapply(prior_list, is.prior.factor))){ + + # test that the prior is either a factor prior or a spike prior + if(!all(sapply(prior_list, is.prior.factor) | sapply(prior_list, is.prior.point) | sapply(prior_list, is.prior.none))) + stop("Factor prior mixture requires that all priors are either factor priors or spike prior distributions") + + # obtain and store the contrast type + priors_type <- .get_prior_factor_list_type(prior_list) + + # change prior none/spikes into factor prior spikes + for(i in seq_along(prior_list)){ + if(is.prior.point(prior_list[[i]])){ + prior_list[[i]] <- prior_factor( + distribution = "point", + parameters = list(location = prior_list[[i]][["parameters"]][["location"]]), + contrast = gsub("prior.", "", priors_type[["class"]], fixed = TRUE) + ) + }else if(is.prior.none(prior_list[[i]])){ + prior_list[[i]] <- prior_factor( + distribution = "point", + parameters = list(location = 0), + contrast = gsub("prior.", "", priors_type[["class"]], fixed = TRUE) + ) + } + } + + attr(prior_list, "K") <- priors_type[["K"]] + class(prior_list) <- c("prior", "prior.factor_mixture", "prior.mixture", priors_type[["class"]]) + + + }else if(any(sapply(prior_list, is.prior.PET)) || any(sapply(prior_list, is.prior.PEESE)) || any(sapply(prior_list, is.prior.weightfunction))){ + + # test that the prior is either a PET, PEESE, or weightfunction prior + if(!all(sapply(prior_list, is.prior.PET) | sapply(prior_list, is.prior.PEESE) | sapply(prior_list, is.prior.weightfunction) | sapply(prior_list, is.prior.none))) + stop("PET/PEESE/weightfunction prior mixture requires that all priors are either PET, PEESE, or weightfunction prior distributions") + + class(prior_list) <- c("prior", "prior.bias_mixture", "prior.mixture") + + + }else if(any(sapply(prior_list, is.prior.simple))){ + + # test that all priors are simple priors + if(!all(sapply(prior_list, is.prior.simple) | sapply(prior_list, is.prior.none))) + stop("Simple prior mixture requires that all priors are simple prior distributions") + + # change none into prior spikes + for(i in seq_along(prior_list)){ + if(is.prior.none(prior_list[[i]])){ + prior_list[[i]] <- prior( + distribution = "point", + parameters = list(location = 0) + ) + } + } + + class(prior_list) <- c("prior", "prior.simple_mixture", "prior.mixture") + + }else{ + stop("The prior mixture must contain either factors, publication bias components, or simple prior distributions.") + } + + attr(prior_list, "components") <- components + attr(prior_list, "prior_weights") <- sapply(prior_list, function(p) p[["prior_weights"]]) + + return(prior_list) +} + #### functions for constructing prior distributions #### .prior_normal <- function(parameters, truncation){ @@ -857,7 +976,7 @@ prior_spike_and_slab <- function(prior_parameter, output <- list() # check overall settings - parameters <- .check_and_name_parameters(parameters, c("steps", "omega"), "two-sided.fixed weightfunction") + parameters <- .check_and_name_parameters(parameters, c("steps", "omega"), "one-sided.fixed weightfunction") # check individual parameters .check_parameter_weigthfunction(parameters$steps, omega = parameters$omega) @@ -944,8 +1063,60 @@ rng.prior <- function(x, n, ...){ }else{ transform_factor_samples <- TRUE } + if(!is.null(dots[["sample_components"]])){ + check_bool(dots[["sample_components"]], "sample_components") + sample_components <- dots[["sample_components"]] + }else{ + sample_components <- FALSE + } + + if(is.prior.spike_and_slab(prior)){ + + inclusion <- stats::rbinom(n, size = 1, prob = rng(prior[["inclusion"]], n)) + + if(sample_components) + return(inclusion) + + x <- rng(prior[["variable"]], n) * inclusion + attr(x, "inclusion") <- inclusion + + }else if(is.prior.mixture(prior)){ + + component_probabilities <- attr(prior, "prior_weights") + components <- sample(seq_along(component_probabilities), size = n, replace = TRUE, prob = component_probabilities) + + if(sample_components) + return(components) + + if(inherits(prior, "prior.factor_mixture")){ + + prior_type <- .get_prior_factor_list_type(prior) + + if(transform_factor_samples){ + x <- matrix(NA, nrow = n, ncol = prior_type[["K"]] + 1) + }else{ + x <- matrix(NA, nrow = n, ncol = prior_type[["K"]]) + } + + for(component in unique(components)){ + x[component == components,] <- rng(prior[[component]], sum(component == components), transform_factor_samples = transform_factor_samples) + } + + }else if(inherits(prior, "prior.simple_mixture")){ + + x <- rep(NA, n) + for(component in unique(components)){ + x[component == components] <- rng(prior[[component]], sum(component == components)) + } + + }else{ + stop("unsupported prior mixture type") + } - if(is.prior.simple(prior)){ + + attr(x, "components") <- components + + }else if(is.prior.simple(prior)){ x <- NULL # guesstimate the number of samples needed before the truncation @@ -1064,10 +1235,6 @@ rng.prior <- function(x, n, ...){ "two.sided.fixed" = rtwo.sided_fixed(n, omega = prior$parameters[["omega"]]) ) - }else if(is.prior.spike_and_slab(prior)){ - - x <- rng(prior[["variable"]], n) * stats::rbinom(n, size = 1, prob = rng(prior[["inclusion"]], n)) - } return(x) @@ -1080,7 +1247,15 @@ cdf.prior <- function(x, q, ...){ .check_q(q) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No cdfs are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No cdfs are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ p <- rep(NA, length(q)) @@ -1116,10 +1291,6 @@ cdf.prior <- function(x, q, ...){ stop("Only marginal cdfs are implemented for prior weightfunctions.") - }else if(is.prior.spike_and_slab(prior)){ - - stop("No cdfs are implemented for spike and slab priors.") - } return(p) @@ -1132,7 +1303,15 @@ ccdf.prior <- function(x, q, ...){ .check_q(q) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No ccdf are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No ccdf are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ p <- rep(NA, length(q)) @@ -1168,10 +1347,6 @@ ccdf.prior <- function(x, q, ...){ stop("Only marginal ccdf functions are implemented for prior weightfunctions.") - }else if(is.prior.spike_and_slab(prior)){ - - stop("No ccdf are implemented for spike and slab priors.") - } return(p) @@ -1185,7 +1360,15 @@ lpdf.prior <- function(x, y, ...){ .check_x(x) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No lpdf are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No lpdf are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ log_lik <- switch( prior[["distribution"]], @@ -1237,10 +1420,6 @@ lpdf.prior <- function(x, y, ...){ stop("Only marginal lpdf are implemented for prior weightfunctions.") - }else if(is.prior.spike_and_slab(prior)){ - - stop("No lpdf are implemented for spike and slab priors.") - } return(log_lik) @@ -1267,7 +1446,15 @@ quant.prior <- function(x, p, ...){ .check_p(p, log.p = FALSE) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No quantile functions are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No quantile functions are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ if(.is_prior_default_range(prior)){ @@ -1319,10 +1506,6 @@ quant.prior <- function(x, p, ...){ stop("Only marginal quantile functions are implemented for prior weightfunctions.") - }else if(is.prior.spike_and_slab(prior)){ - - stop("No quantile functions are implemented for spike and slab priors.") - } return(q) @@ -1416,7 +1599,15 @@ mcdf.prior <- function(x, q, ...){ .check_q(q) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No mcdf are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No mcdf are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ p <- cdf(prior, q) @@ -1475,10 +1666,6 @@ mcdf.prior <- function(x, q, ...){ "mpoint" = ppoint(q, location = 0) ) - }else if(is.prior.spike_and_slab(prior)){ - - stop("No cdf are implemented for spike and slab priors.") - } return(p) @@ -1491,7 +1678,15 @@ mccdf.prior <- function(x, q, ...){ .check_q(q) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No mccdf are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No mccdf are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ p <- ccdf(prior, q) @@ -1550,10 +1745,6 @@ mccdf.prior <- function(x, q, ...){ "mpoint" = ppoint(q, location = 0, lower.tail = FALSE), ) - }else if(is.prior.spike_and_slab(prior)){ - - stop("No mccdf are implemented for spike and slab priors.") - } return(p) @@ -1567,7 +1758,15 @@ mlpdf.prior <- function(x, y, ...){ .check_x(x) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No mlpdf are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No mlpdf are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ log_lik <- lpdf(prior, x) @@ -1626,10 +1825,6 @@ mlpdf.prior <- function(x, y, ...){ "mpoint" = dpoint(x, location = 0, log = TRUE), ) - }else if(is.prior.spike_and_slab(prior)){ - - stop("No lpdf are implemented for spike and slab priors.") - } return(log_lik) @@ -1656,7 +1851,15 @@ mquant.prior <- function(x, p, ...){ .check_p(p, log.p = FALSE) .check_prior(prior) - if(is.prior.simple(prior)){ + if(is.prior.spike_and_slab(prior)){ + + stop("No quantile functions are implemented for spike and slab priors.") + + }else if(is.prior.mixture(prior)){ + + stop("No quantile functions are implemented for prior mixtures.") + + }else if(is.prior.simple(prior)){ q <- quant(prior, p) @@ -1715,10 +1918,6 @@ mquant.prior <- function(x, p, ...){ "mpoint" = qpoint(p, location = 0) ) - }else if(is.prior.spike_and_slab(prior)){ - - stop("No quantile functions are implemented for spike and slab priors.") - } return(q) @@ -1838,7 +2037,15 @@ mean.prior <- function(x, ...){ .check_prior(x, "x") - if(is.prior.simple(x)){ + if(is.prior.spike_and_slab(x)){ + + m <- mean(x[["variable"]]) * mean(x[["inclusion"]]) + + }else if(is.prior.mixture(x)){ + + stop("No mean is implemented for prior mixtures.") + + }else if(is.prior.simple(x)){ if(.is_prior_default_range(x)){ @@ -1908,10 +2115,6 @@ mean.prior <- function(x, ...){ m <- 0 } - }else if(is.prior.spike_and_slab(x)){ - - m <- mean(x[["variable"]]) * mean(x[["inclusion"]]) - } return(m) @@ -1984,7 +2187,21 @@ var.prior <- function(x, ...){ .check_prior(x, "x") - if(is.prior.simple(x)){ + if(is.prior.spike_and_slab(x)){ + + # the inclusion is always beta -> indicators are betabinom + var_inclusion <- with(x[["inclusion"]][["parameters"]], (alpha * beta * (alpha + beta + 1) ) / ( (alpha + beta)^2 * (alpha + beta + 1) ) ) + + var <- + (var(x[["variable"]]) + mean(x[["variable"]])^2) * + (var_inclusion + mean(x[["inclusion"]])^2) - + (mean(x[["variable"]])^2 * mean(x[["inclusion"]])^2) + + }else if(is.prior.mixture(x)){ + + stop("No var is implemented for prior mixtures.") + + }else if(is.prior.simple(x)){ if(.is_prior_default_range(x)){ @@ -2082,17 +2299,6 @@ var.prior <- function(x, ...){ "mt" = var.prior(prior("t", parameters = list(location = 0, scale = par2, df = x$parameters[["df"]])))) } - }else if(is.prior.spike_and_slab(x)){ - - # the inclusion is always beta -> indicators are betabinom - var_inclusion <- with(x[["inclusion"]][["parameters"]], (alpha * beta * (alpha + beta + 1) ) / ( (alpha + beta)^2 * (alpha + beta + 1) ) ) - - - var <- - (var(x[["variable"]]) + mean(x[["variable"]])^2) * - (var_inclusion + mean(x[["inclusion"]])^2) - - (mean(x[["variable"]])^2 * mean(x[["inclusion"]])^2) - } return(var) diff --git a/R/summary-tables.R b/R/summary-tables.R index 9134977b..1e2f5af4 100644 --- a/R/summary-tables.R +++ b/R/summary-tables.R @@ -588,6 +588,8 @@ marginal_estimates_table <- function(samples, inference, parameters, probs = c(0 #' should be excluded from the summary table. Defaults to \code{FALSE}. #' @param remove_parameters parameters to be removed from the summary. Defaults #' to \code{NULL}, i.e., including all parameters. +#' @param return_samples whether to return the transoformed and formated samples +#' instead of the table. Defaults to \code{FALSE}. #' @inheritParams BayesTools_ensemble_tables #' #' @@ -615,7 +617,8 @@ marginal_estimates_table <- function(samples, inference, parameters, probs = c(0 NULL #' @rdname BayesTools_model_tables -model_summary_table <- function(model, model_description = NULL, title = NULL, footnotes = NULL, warnings = NULL, remove_spike_0 = TRUE, short_name = FALSE, formula_prefix = TRUE, remove_parameters = NULL){ +model_summary_table <- function(model, model_description = NULL, title = NULL, footnotes = NULL, warnings = NULL, + remove_spike_0 = TRUE, short_name = FALSE, formula_prefix = TRUE, remove_parameters = NULL){ # check input check_list(model, "model", check_names = "inference", allow_other = TRUE, all_objects = TRUE) @@ -663,8 +666,8 @@ model_summary_table <- function(model, model_description = NULL, title = NULL, f next }else if(is.prior.weightfunction(prior_list[[i]]) | is.prior.PET(prior_list[[i]]) | is.prior.PEESE(prior_list[[i]])){ temp_prior <- print(prior_list[[i]], silent = TRUE, short_name = short_name) - }else if(is.prior.simple(prior_list[[i]]) | is.prior.vector(prior_list[[i]]) | is.prior.factor(prior_list[[i]]) | is.prior.spike_and_slab(prior_list[[i]])){ - temp_prior <- paste0(names(prior_list)[i], " ~ " , print(prior_list[[i]], silent = TRUE, short_name = short_name)) + }else if(is.prior.simple(prior_list[[i]]) | is.prior.vector(prior_list[[i]]) | is.prior.factor(prior_list[[i]]) | is.prior.spike_and_slab(prior_list[[i]]) | is.prior.mixture(prior_list[[i]])){ + temp_prior <- paste0(names(prior_list)[i], " ~ " , print(prior_list[[i]], silent = TRUE, short_name = short_name, inline = TRUE)) }else if(is.prior.point(prior_list[[i]])){ temp_prior <- paste0(names(prior_list)[i], " = " , print(prior_list[[i]], silent = TRUE, short_name = short_name)) } @@ -708,7 +711,9 @@ model_summary_table <- function(model, model_description = NULL, title = NULL, f } #' @rdname BayesTools_model_tables -runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, footnotes = NULL, warnings = NULL, conditional = FALSE, remove_spike_0 = TRUE, transform_factors = FALSE, transform_orthonormal = FALSE, formula_prefix = TRUE, remove_inclusion = FALSE, remove_parameters = NULL){ +runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, footnotes = NULL, warnings = NULL, conditional = FALSE, + remove_spike_0 = TRUE, transform_factors = FALSE, transform_orthonormal = FALSE, formula_prefix = TRUE, remove_inclusion = FALSE, remove_parameters = NULL, + return_samples = FALSE){ .check_runjags() # most of the code is shared with .diagnostics_plot_data function (keep them in sync on update) @@ -738,64 +743,53 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, # depreciate transform_factors <- .depreciate.transform_orthonormal(transform_orthonormal, transform_factors) - # obtain model information - invisible(utils::capture.output(runjags_summary <- suppressWarnings(summary(fit, silent.jags = TRUE)))) - runjags_summary <- data.frame(runjags_summary) - model_samples <- suppressWarnings(coda::as.mcmc(fit)) + # get model samples + model_samples <- suppressWarnings(coda::as.mcmc(fit)) - # change HPD to quantile intervals - for(par in rownames(runjags_summary)){ - runjags_summary[par, "Lower95"] <- stats::quantile(model_samples[,par], .025, na.rm = TRUE) - runjags_summary[par, "Upper95"] <- stats::quantile(model_samples[,par], .975, na.rm = TRUE) - } + ### remove un-wanted estimates (or support values) - spike and slab priors already dealt with later (also remove the item from prior list) + for(i in rev(seq_along(prior_list))){ - # deal with missing median in case of non-stochastic variables - if(!any(colnames(runjags_summary) == "Median")){ - runjags_summary[,"Median"] <- NA - } + if(is.prior.simple(prior_list[[i]]) && prior_list[[i]][["distribution"]] == "invgamma"){ + ## invgamma support parameter + model_samples <- model_samples[,colnames(model_samples) != paste0("inv_",names(prior_list)[i]),drop=FALSE] + } - # remove un-wanted estimates (or support values) - spike and slab priors already dealt with later - # also remove the item from prior list - for(i in rev(seq_along(prior_list))){ if(is.prior.weightfunction(prior_list[[i]])){ + ## simple weight functions # remove etas if(prior_list[[i]][["distribution"]] %in% c("one.sided", "two.sided")){ - runjags_summary <- runjags_summary[!grepl("eta", rownames(runjags_summary)),,drop=FALSE] + model_samples <- model_samples[,!grepl("eta", colnames(model_samples)),drop=FALSE] } - # remove wrong diagnostics for the constant - runjags_summary[max(grep("omega", rownames(runjags_summary))),c("MCerr", "MC.ofSD","SSeff","psrf")] <- NA - # reorder - runjags_summary[grep("omega", rownames(runjags_summary)),] <- runjags_summary[rev(grep("omega", rownames(runjags_summary))),] - # rename - omega_cuts <- weightfunctions_mapping(prior_list[i], cuts_only = TRUE) - omega_names <- sapply(1:(length(omega_cuts)-1), function(i)paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) - rownames(runjags_summary)[grep("omega", rownames(runjags_summary))] <- omega_names - # remove if requested + + # rename the omegas + omega_cuts <- weightfunctions_mapping(prior_list[i], cuts_only = TRUE) + omega_names_old <- paste0("omega[", 1:(length(omega_cuts)-1),"]") + omega_names <- sapply(1:(length(omega_cuts)-1), function(i)paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) + + # change the order of omegas + model_samples[,which(colnames(model_samples) %in% omega_names_old)] <- model_samples[,rev(which(colnames(model_samples) %in% omega_names_old)),drop=FALSE] + colnames(model_samples)[which(colnames(model_samples) %in% omega_names_old)] <- omega_names + + # remove omegas if requested if("omega" %in% remove_parameters){ - prior_list[[i]] <- NULL - runjags_summary <- runjags_summary[,!rownames(runjags_summary) %in% omega_names] + model_samples <- model_samples[,!colnames(model_samples) %in% omega_names,drop=FALSE] + prior_list[i] <- NULL } + }else if((remove_spike_0 && is.prior.point(prior_list[[i]]) && prior_list[[i]][["parameters"]][["location"]] == 0) || (names(prior_list)[[i]] %in% remove_parameters)){ + ## zero spike priors or other parameters to be removed if(is.prior.factor(prior_list[[i]])){ - runjags_summary <- runjags_summary[!rownames(runjags_summary) %in% .JAGS_prior_factor_names(names(prior_list)[i], prior_list[[i]]),,drop=FALSE] + model_samples <- model_samples[,!colnames(model_samples) %in% .JAGS_prior_factor_names(names(prior_list)[i], prior_list[[i]]),drop=FALSE] }else{ - runjags_summary <- runjags_summary[rownames(runjags_summary) != names(prior_list)[i],,drop=FALSE] - } - if(prior_list[[i]][["distribution"]] == "invgamma"){ - runjags_summary <- runjags_summary[rownames(runjags_summary) != paste0("inv_",names(prior_list)[i]),,drop=FALSE] + model_samples <- model_samples[,colnames(model_samples) != names(prior_list)[i],drop=FALSE] } prior_list[i] <- NULL - }else if(is.prior.simple(prior_list[[i]]) && prior_list[[i]][["distribution"]] == "invgamma"){ - runjags_summary <- runjags_summary[rownames(runjags_summary) != paste0("inv_",names(prior_list)[i]),,drop=FALSE] } - } - # remove transformations for removed variables - if(!is.null(transformations)){ - transformations <- transformations[names(transformations) %in% names(prior_list)] } - # simplify spike and slab priors to simple priors -- the samples and summary can be dealt with as any other prior + # simplify mixture and spike and slab priors to simple priors + # the samples and summary can be dealt with as any other prior (i.e., transformations later) for(par in names(prior_list)){ if(is.prior.spike_and_slab(prior_list[[par]])){ @@ -813,41 +807,221 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, # change the samples between conditional/averaged based on the preferences if(conditional){ - # set the spike samples to NA - model_samples[ - model_samples[,colnames(model_samples) == paste0(par, "_indicator")] == 0, - colnames(model_samples) %in% par_names] <- NA - - # recompute the summaries - runjags_summary[par_names, "Mean"] <- mean(model_samples[,par_names], na.rm = TRUE) - runjags_summary[par_names, "Median"] <- stats::median(model_samples[,par_names], na.rm = TRUE) - runjags_summary[par_names, "SD"] <- sd(model_samples[,par_names], na.rm = TRUE) - runjags_summary[par_names, "Lower95"] <- stats::quantile(model_samples[,par_names], .025, na.rm = TRUE) - runjags_summary[par_names, "Upper95"] <- stats::quantile(model_samples[,par_names], .975, na.rm = TRUE) + # compute the number of conditional samples + n_conditional_samples <- sum(model_samples[,colnames(model_samples) == paste0(par, "_indicator")] == 1) + + # replace null samples with NAs (important for later transformations) + model_samples[model_samples[,colnames(model_samples) == paste0(par, "_indicator")] != 1, par_names] <- NA + + # add warnings about conditional summary + warnings <- c(warnings, .runjags_conditional_warning(par_names, n_conditional_samples)) } - # remove the indicator - runjags_summary <- runjags_summary[rownames(runjags_summary) != paste0(par, "_indicator"),,drop=FALSE] - model_samples <- model_samples[colnames(runjags_summary) != paste0(par, "_indicator"),,drop=FALSE] + # remove the inclusion + model_samples <- model_samples[,colnames(model_samples) != paste0(par, "_inclusion"),drop=FALSE] # remove the latent variable - runjags_summary <- runjags_summary[!rownames(runjags_summary) %in% gsub(par, paste0(par, "_variable"), par_names),,drop=FALSE] - model_samples <- model_samples[!colnames(runjags_summary) %in% gsub(par, paste0(par, "_variable"), par_names),,drop=FALSE] + model_samples <- model_samples[,!colnames(model_samples) %in% gsub(par, paste0(par, "_variable"), par_names),drop=FALSE] # remove/rename the inclusions probabilities if(remove_inclusion){ - runjags_summary <- runjags_summary[rownames(runjags_summary) != paste0(par, "_inclusion"),,drop=FALSE] - model_samples <- model_samples[colnames(runjags_summary) != paste0(par, "_inclusion"),,drop=FALSE] + model_samples <- model_samples[,colnames(model_samples) != paste0(par, "_indicator"),drop=FALSE] }else{ - rownames(runjags_summary)[rownames(runjags_summary) == paste0(par, "_inclusion")] <- paste0(par, " (inclusion)") - colnames(model_samples)[colnames(model_samples) == paste0(par, "_inclusion")] <- paste0(par, " (inclusion)") + colnames(model_samples)[colnames(model_samples) == paste0(par, "_indicator")] <- paste0(par, " (inclusion)") } # modify the parameter list prior_list[[par]] <- prior_list[[par]]$variable + + }else if(is.prior.mixture(prior_list[[par]])){ + + # check for publication bias component + is_PET <- sapply(prior_list[[par]], is.prior.PET) + is_PEESE <- sapply(prior_list[[par]], is.prior.PEESE) + is_weightfunction <- sapply(prior_list[[par]], is.prior.weightfunction) + + # distinguish between null/alternative and component type notations + components <- attr(prior_list[[par]], "components") + + if(any(is_PET | is_PEESE | is_weightfunction)){ + + # change the samples between conditional/averaged based on the preferences + if(conditional){ + + if(any(is_PET)){ + # compute the number of conditional samples + n_conditional_samples <- sum(model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(is_PET)) + + # replace null samples with NAs (important for later transformations) + model_samples[!model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(is_PET), "PET"] <- NA + + # add warnings about conditional summary + warnings <- c(warnings, .runjags_conditional_warning("PET", n_conditional_samples)) + } + + if(any(is_PEESE)){ + # compute the number of conditional samples + n_conditional_samples <- sum(model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(is_PEESE)) + + # replace null samples with NAs (important for later transformations) + model_samples[!model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(is_PEESE), "PEESE"] <- NA + + # add warnings about conditional summary + warnings <- c(warnings, .runjags_conditional_warning("PEESE", n_conditional_samples)) + } + + if(any(is_weightfunction)){ + # compute the number of conditional samples + n_conditional_samples <- sum(model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(is_weightfunction)) + + # replace null samples with NAs (important for later transformations) + model_samples[!model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(is_weightfunction), grepl("omega", colnames(model_samples))] <- NA + + # add warnings about conditional summary + warnings <- c(warnings, .runjags_conditional_warning("omega", n_conditional_samples)) + } + + } + + # re-format the weightfunctions + if(any(is_weightfunction)){ + + # reorder + model_samples[,grep("omega", colnames(model_samples))] <- model_samples[,rev(grep("omega", colnames(model_samples))),drop=FALSE] + + # rename (the order does not need to be changed since the mixture combination returs oposite order to single priors) + omega_cuts <- weightfunctions_mapping(prior_list[[par]][is_weightfunction], cuts_only = TRUE, one_sided = TRUE) + omega_names_old <- paste0("omega[", 1:(length(omega_cuts)-1),"]") + omega_names <- sapply(1:(length(omega_cuts)-1), function(i)paste0("omega[",omega_cuts[i],",",omega_cuts[i+1],"]")) + colnames(model_samples)[which(colnames(model_samples) %in% omega_names_old)] <- omega_names + + # remove if requested + if("omega" %in% remove_parameters){ + model_samples <- model_samples[,!colnames(model_samples) %in% omega_names,drop=FALSE] + prior_list[[par]][is_weightfunction] <- NULL + } + } + + # add the simpler priors to the prior list + if(any(is_PET)){ + prior_list[["PET"]] <- prior_list[[par]][is_PET][1] + } + if(any(is_PEESE)){ + prior_list[["PEESE"]] <- prior_list[[par]][is_PEESE][1] + } + if(any(is_weightfunction)){ + prior_list[["omega"]] <- prior_list[[par]][is_weightfunction][1] + } + + }else{ + + # prepare parameter names + par_names <- par + + # change the samples between conditional/averaged based on the preferences + if(conditional){ + + if(all(components %in% c("null", "alternative"))){ + + # select the corresponding indicators + this_component_indicator <- which(components == "alternative") + + # compute the number of conditional samples + n_conditional_samples <- sum(model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% this_component_indicator) + + # replace null samples with NAs (important for later transformations) + model_samples[!model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% this_component_indicator, par_names] <- NA + + # add warnings about conditional summary + warnings <- c(warnings, .runjags_conditional_warning(par_names, n_conditional_samples)) + + }else{ + + # remove the join samples and replace with individual conditional samples + temp_position <- min(which(colnames(model_samples) %in% par)) + temp_all_samples <- model_samples[, colnames(model_samples) %in% par,drop=FALSE] + temp_new_samples <- list() + model_samples <- model_samples[,!colnames(model_samples) %in% par,drop=FALSE] + + # component-by-component replacement + for(component in unique(components[components != "null"])){ + + # create component specific samples + temp_par_names <- paste0(par_names, "[", component, "]") + temp_new_samples[[component]] <- temp_all_samples + colnames(temp_new_samples[[component]]) <- temp_par_names + + # select the corresponding indicators + this_component_indicator <- which(components == component) + + # compute the number of conditional samples + n_conditional_samples <- sum(model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% this_component_indicator) + + # replace null samples with NAs (important for later transformations) + temp_new_samples[[component]][!model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% this_component_indicator,] <- NA + + # add warnings about conditional summary + warnings <- c(warnings, .runjags_conditional_warning(temp_par_names, n_conditional_samples)) + + # forward transformations to the conditional estimates + if(!is.null(transformations[[par]])){ + transformations[[temp_par_names]] <- transformations[[par]] + prior_list[[temp_par_names]] <- prior_list[[par]][which(components == component)][1] + } + } + + # place the transformed samples back + model_samples <- cbind( + if(temp_position > 1) model_samples[,1:(temp_position-1),drop=FALSE], + do.call(cbind, temp_new_samples), + if(temp_position <= ncol(model_samples)) model_samples[,temp_position:ncol(model_samples),drop=FALSE] + ) + + # remove the original parameter transformations + if(!is.null(transformations[[par]])){ + transformations[[par]] <- NULL + prior_list[[par]] <- NULL + } + } + } + } + + # remove/rename the inclusions probabilities + if(remove_inclusion){ + model_samples <- model_samples[,colnames(model_samples) != paste0(par, "_indicator"),drop=FALSE] + }else{ + if(all(components %in% c("null", "alternative"))){ + # replace and rename in the samples + model_samples[,colnames(model_samples) == paste0(par, "_indicator")] <- ifelse( + model_samples[,colnames(model_samples) == paste0(par, "_indicator")] %in% which(components == "alternative"), 1, 0) + colnames(model_samples)[colnames(model_samples) == paste0(par, "_indicator")] <- paste0(par, " (inclusion)") + }else{ + # extract + temp_position <- min(which(colnames(model_samples) %in% paste0(par, "_indicator"))) + temp_samples <- model_samples[,colnames(model_samples) == paste0(par, "_indicator")] + model_samples <- model_samples[,colnames(model_samples) != paste0(par, "_indicator"),drop=FALSE] + + # compute component specific indicators + temp_new_samples <- lapply(unique(components), function(component) ifelse(temp_samples %in% which(components == component), 1, 0)) + temp_new_samples <- do.call(cbind, temp_new_samples) + colnames(temp_new_samples) <- paste0(par, " (inclusion: ", unique(components),")") + + # place the transformed samples back + model_samples <- cbind( + if(temp_position > 1) model_samples[,1:(temp_position-1),drop=FALSE], + temp_new_samples, + if(temp_position <= ncol(model_samples)) model_samples[,temp_position:ncol(model_samples),drop=FALSE] + ) + } + } } } + # remove transformations for removed variables + if(!is.null(transformations)){ + transformations <- transformations[names(transformations) %in% names(prior_list)] + } + # apply transformations (not orthornormal if they are to be returned transformed to diffs) if(!is.null(transformations)){ for(par in names(transformations)){ @@ -855,13 +1029,6 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, # non-factor priors model_samples[,par] <- do.call(transformations[[par]][["fun"]], c(list(model_samples[,par]), transformations[[par]][["arg"]])) - runjags_summary[par, "Mean"] <- mean(model_samples[,par], na.rm = TRUE) - runjags_summary[par, "SD"] <- sd(model_samples[,par], na.rm = TRUE) - runjags_summary[par, "Lower95"] <- stats::quantile(model_samples[,par], .025, na.rm = TRUE) - runjags_summary[par, "Upper95"] <- stats::quantile(model_samples[,par], .975, na.rm = TRUE) - runjags_summary[par, "Median"] <- do.call(transformations[[par]][["fun"]], c(list(runjags_summary[par, "Median"]), transformations[[par]][["arg"]])) - runjags_summary[par, "MCerr"] <- do.call(transformations[[par]][["fun"]], c(list(runjags_summary[par, "MCerr"]), transformations[[par]][["arg"]])) - runjags_summary[par, "MC.ofSD"] <- 100 * runjags_summary[par, "MCerr"] / runjags_summary[par, "SD"] }else if((!transform_factors && (is.prior.orthonormal(prior_list[[par]]) | is.prior.meandif(prior_list[[par]]))) || is.prior.treatment(prior_list[[par]])){ @@ -870,17 +1037,8 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, for(i in seq_along(par_names)){ model_samples[,par_names[i]] <- do.call(transformations[[par]][["fun"]], c(list(model_samples[,par_names[i]]), transformations[[par]][["arg"]])) - runjags_summary[par_names[i], "Mean"] <- mean(model_samples[,par_names[i]], na.rm = TRUE) - runjags_summary[par_names[i], "SD"] <- sd(model_samples[,par_names[i]], na.rm = TRUE) - runjags_summary[par_names[i], "Lower95"] <- stats::quantile(model_samples[,par_names[i]], .025, na.rm = TRUE) - runjags_summary[par_names[i], "Upper95"] <- stats::quantile(model_samples[,par_names[i]], .975, na.rm = TRUE) - runjags_summary[par_names[i], "Median"] <- do.call(transformations[[par]][["fun"]], c(list(runjags_summary[par_names[i], "Median"]), transformations[[par]][["arg"]])) - runjags_summary[par_names[i], "MCerr"] <- do.call(transformations[[par]][["fun"]], c(list(runjags_summary[par_names[i], "MCerr"]), transformations[[par]][["arg"]])) - runjags_summary[par_names[i], "MC.ofSD"] <- 100 * runjags_summary[par_names[i], "MCerr"] / runjags_summary[par_names[i], "SD"] } - } - } } @@ -891,12 +1049,14 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, par_names <- .JAGS_prior_factor_names(par, prior_list[[par]]) - original_samples <- model_samples[,par_names,drop = FALSE] + temp_position <- min(which(colnames(model_samples) %in% par_names)) + temp_samples <- model_samples[, colnames(model_samples) %in% par_names,drop=FALSE] + model_samples <- model_samples[,!colnames(model_samples) %in% par_names,drop=FALSE] if(is.prior.orthonormal(prior_list[[par]])){ - transformed_samples <- original_samples %*% t(contr.orthonormal(1:(.get_prior_factor_levels(prior_list[[par]])+1))) + transformed_samples <- temp_samples %*% t(contr.orthonormal(1:(.get_prior_factor_levels(prior_list[[par]])+1))) }else if(is.prior.meandif(prior_list[[par]])){ - transformed_samples <- original_samples %*% t(contr.meandif(1:(.get_prior_factor_levels(prior_list[[par]])+1))) + transformed_samples <- temp_samples %*% t(contr.meandif(1:(.get_prior_factor_levels(prior_list[[par]])+1))) } # apply transformation if specified @@ -918,74 +1078,29 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, } colnames(transformed_samples) <- transformed_names - # update samples - model_samples <- model_samples[,!colnames(model_samples) %in% par_names,drop=FALSE] - model_samples <- cbind(model_samples, transformed_samples) - - # update summary - if(anyNA(transformed_samples)){ - # remove NA's introduced by conditional models and spike & slab priors -- also removes the - transformed_chains <- lapply(split(data.frame(transformed_samples), sort(rep(1:length(fit[["mcmc"]]), fit[["sample"]]))), function(x) coda::mcmc(stats::na.omit(x))) - transformed_summary <- summary(runjags::combine.mcmc(transformed_chains, collapse.chains = FALSE)) - transformed_summary <- cbind( - Lower95 = transformed_summary$quantiles[,"2.5%"], - Median = transformed_summary$quantiles[,"50%"], - Upper95 = transformed_summary$quantiles[,"97.5%"], - Mean = transformed_summary$statistics[,"Mean"], - SD = transformed_summary$statistics[,"SD"], - Mode = NA, - MCerr = NA, - MC.ofSD = NA, - SSeff = NA, - AC.10 = NA, - psrf = NA - ) - }else{ - transformed_chains <- lapply(split(data.frame(transformed_samples), sort(rep(1:length(fit[["mcmc"]]), fit[["sample"]]))), coda::mcmc) - transformed_summary <- summary(runjags::combine.mcmc(transformed_chains, collapse.chains = FALSE)) - transformed_summary <- cbind( - Lower95 = transformed_summary$quantiles[,"2.5%"], - Median = transformed_summary$quantiles[,"50%"], - Upper95 = transformed_summary$quantiles[,"97.5%"], - Mean = transformed_summary$statistics[,"Mean"], - SD = transformed_summary$statistics[,"SD"], - Mode = NA, - MCerr = if(is.prior.point(prior_list[[par]])) NA else transformed_summary$statistics[,"Naive SE"], - MC.ofSD = if(is.prior.point(prior_list[[par]])) NA else 100 * transformed_summary$statistics[,"Naive SE"] / transformed_summary$statistics[,"SD"], - SSeff = if(is.prior.point(prior_list[[par]])) NA else unname(coda::effectiveSize(coda::as.mcmc(transformed_samples))), - AC.10 = if(is.prior.point(prior_list[[par]])) NA else coda::autocorr.diag(coda::as.mcmc(transformed_samples), lags = 10)[1,], - psrf = if(is.prior.point(prior_list[[par]])) NA else if(length(fit$mcmc) > 1) unname(coda::gelman.diag(transformed_chains, multivariate = FALSE)$psrf[,"Point est."]) else NA - ) - } - - rownames(transformed_summary) <- transformed_names - - par_index <- which.max(rownames(runjags_summary) %in% par_names) - runjags_summary <- runjags_summary[!rownames(runjags_summary) %in% par_names,] - runjags_summary <- rbind( - if(par_index > 1) runjags_summary[1:(par_index-1),], - transformed_summary, - if(par_index <= nrow(runjags_summary)) runjags_summary[par_index:nrow(runjags_summary),] + # place the transformed samples back + model_samples <- cbind( + if(temp_position > 1) model_samples[,1:(temp_position-1),drop=FALSE], + transformed_samples, + if(temp_position <= ncol(model_samples)) model_samples[,temp_position:ncol(model_samples),drop=FALSE] ) + } } - # remove un-wanted columns - runjags_summary <- runjags_summary[,!colnames(runjags_summary) %in% c("Mode", "AC.10"),drop = FALSE] - # rename treatment factor levels if(any(sapply(prior_list, is.prior.treatment))){ for(par in names(prior_list)[sapply(prior_list, is.prior.treatment)]){ if(!.is_prior_interaction(prior_list[[par]])){ if(.get_prior_factor_levels(prior_list[[par]]) == 1){ - rownames(runjags_summary)[rownames(runjags_summary) == par] <- + colnames(model_samples)[colnames(model_samples) == par] <- paste0(par,"[",.get_prior_factor_level_names(prior_list[[par]])[-1], "]") }else{ - rownames(runjags_summary)[rownames(runjags_summary) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- + colnames(model_samples)[colnames(model_samples) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- paste0(par,"[",.get_prior_factor_level_names(prior_list[[par]])[-1], "]") } }else if(length(attr(prior_list[[par]], "levels")) == 1){ - rownames(runjags_summary)[rownames(runjags_summary) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- + colnames(model_samples)[colnames(model_samples) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- paste0(par,"[",.get_prior_factor_level_names(prior_list[[par]])[[1]][-1], "]") } } @@ -996,49 +1111,46 @@ runjags_estimates_table <- function(fit, transformations = NULL, title = NULL, for(par in names(prior_list)[sapply(prior_list, is.prior.independent)]){ if(!.is_prior_interaction(prior_list[[par]])){ if(.get_prior_factor_levels(prior_list[[par]]) == 1){ - rownames(runjags_summary)[rownames(runjags_summary) == par] <- + colnames(model_samples)[colnames(model_samples) == par] <- paste0(par,"[",.get_prior_factor_level_names(prior_list[[par]]), "]") }else{ - rownames(runjags_summary)[rownames(runjags_summary) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- + colnames(model_samples)[colnames(model_samples) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- paste0(par,"[",.get_prior_factor_level_names(prior_list[[par]]), "]") } }else if(length(attr(prior_list[[par]], "levels")) == 1){ - rownames(runjags_summary)[rownames(runjags_summary) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- + colnames(model_samples)[colnames(model_samples) %in% paste0(par,"[",1:.get_prior_factor_levels(prior_list[[par]]),"]")] <- paste0(par,"[",.get_prior_factor_level_names(prior_list[[par]])[[1]], "]") } } } # store parameter names before removing formula attachments - parameter_names <- rownames(runjags_summary) + parameter_names <- colnames(model_samples) # rename formula parameters if(any(!sapply(lapply(prior_list, attr, which = "parameter"), is.null))){ - rownames(runjags_summary) <- format_parameter_names( - parameters = rownames(runjags_summary), + colnames(model_samples) <- format_parameter_names( + parameters = colnames(model_samples), formula_parameters = unique(unlist(lapply(prior_list, attr, which = "parameter"))), formula_prefix = formula_prefix) } + # return samples if requested + if(return_samples){ + attr(model_samples, "prior_list") <- prior_list + return(model_samples) + } - # rename the rest - colnames(runjags_summary)[colnames(runjags_summary) == "Lower95"] <- "lCI" - colnames(runjags_summary)[colnames(runjags_summary) == "Upper95"] <- "uCI" - colnames(runjags_summary)[colnames(runjags_summary) == "MCerr"] <- "MCMC_error" - colnames(runjags_summary)[colnames(runjags_summary) == "MC.ofSD"] <- "MCMC_SD_error" - colnames(runjags_summary)[colnames(runjags_summary) == "SSeff"] <- "ESS" - colnames(runjags_summary)[colnames(runjags_summary) == "psrf"] <- "R_hat" - - # change the SD error to a fraction - runjags_summary[, "MCMC_SD_error"] <- runjags_summary[, "MCMC_SD_error"] / 100 - - # reorder the columns - runjags_summary <- runjags_summary[,c("Mean", "SD", "lCI", "Median", "uCI", "MCMC_error", "MCMC_SD_error", "ESS", "R_hat"), drop = FALSE] - runjags_summary <- data.frame(runjags_summary) + # compute the summary + if(ncol(model_samples) == 0){ + return(runjags_estimates_empty_table(title = title, footnotes = footnotes, warnings = warnings)) + }else{ + runjags_summary <- .runjags_summary_fast(model_samples, n_samples = fit$sample, n_chains = length(fit$mcmc), conditional = conditional) + } # prepare output class(runjags_summary) <- c("BayesTools_table", "BayesTools_runjags_summary", class(runjags_summary)) - attr(runjags_summary, "type") <- c(rep("estimate", 5), "MCMC_error", "MCMC_SD_error", "ESS", "R_hat") + attr(runjags_summary, "type") <- c(rep("estimate", 5), if(!conditional) c("MCMC_error", "MCMC_SD_error", "ESS", "R_hat")) attr(runjags_summary, "parameters") <- parameter_names attr(runjags_summary, "rownames") <- TRUE attr(runjags_summary, "title") <- title @@ -1066,7 +1178,7 @@ runjags_inference_table <- function(fit, title = NULL, footnotes = NULL, warnin check_bool(formula_prefix, "formula_prefix") # return empty table if none of the priors is spike and slab - if(!any(sapply(prior_list, is.prior.spike_and_slab))){ + if(!any(sapply(prior_list, function(p) is.prior.spike_and_slab(p) | is.prior.mixture(p)))){ runjags_summary <- runjags_inference_empty_table(title = title, footnotes = footnotes, warnings = warnings) return(runjags_summary) } @@ -1087,20 +1199,69 @@ runjags_inference_table <- function(fit, title = NULL, footnotes = NULL, warnin post_prob = temp_post_prob, inclusion_BF = (temp_post_prob / (1-temp_post_prob)) / (temp_prior_prob / (1-temp_prior_prob)) )) + }else if(is.prior.mixture(prior_list[[par]])){ + + # extract the components and prior probabilities + components <- attr(prior_list[[par]], "components") + temp_prior_prob <- attr(prior_list[[par]], "prior_weights") + temp_prior_prob <- sapply(unique(components), function(component) sum(temp_prior_prob[which(components == component)])) / sum(temp_prior_prob) + temp_post_prob <- sapply(unique(components), function(component) mean(model_samples[,paste0(par, "_indicator")] %in% which(components == component))) + + # if only null and alternative are specified, removed the null component + if(all(components %in% c("null", "alternative"))){ + + if(all(components == "null")){ + temp_prior_prob <- c(temp_prior_prob, "alternative" = 0) + temp_post_prob <- c(temp_post_prob, "alternative" = 0) + } + if(all(components == "alternative")){ + temp_prior_prob <- c("null" = 0, temp_prior_prob) + temp_post_prob <- c("null" = 0, temp_post_prob) + } + + runjags_summary <- rbind(runjags_summary, data.frame( + Parameter = par, + prior_prob = temp_prior_prob[["alternative"]], + post_prob = temp_post_prob[["alternative"]], + inclusion_BF = inclusion_BF(prior_probs = temp_prior_prob, post_probs = temp_post_prob, is_null = names(temp_post_prob) != "alternative") + )) + + }else{ + + # compute summary for each component + for(component in unique(components)){ + runjags_summary <- rbind(runjags_summary, data.frame( + Parameter = paste0(par, " [", component, "]"), + prior_prob = temp_prior_prob[[component]], + post_prob = temp_post_prob[[component]], + inclusion_BF = inclusion_BF(prior_probs = temp_prior_prob, post_probs = temp_post_prob, is_null = names(temp_post_prob) != component) + )) + } + + } } } - runjags_summary$Parameter <- format_parameter_names( - parameters = runjags_summary$Parameter, - formula_parameters = unique(unlist(lapply(prior_list, attr, which = "parameter"))), - formula_prefix = formula_prefix) + # store parameter names before removing formula attachments + parameter_names <- runjags_summary$Parameter + rownames(runjags_summary) <- parameter_names + runjags_summary <- runjags_summary[,-1] - class(runjags_summary) <- c("BayesTools_table", "BayesTools_runjags_summary", class(runjags_summary)) - attr(runjags_summary, "type") <- c("string", "prior_prob", "post_prob", "inclusion_BF") - attr(runjags_summary, "rownames") <- FALSE - attr(runjags_summary, "title") <- title - attr(runjags_summary, "footnotes") <- footnotes - attr(runjags_summary, "warnings") <- warnings + # rename formula parameters + if(any(!sapply(lapply(prior_list, attr, which = "parameter"), is.null))){ + rownames(runjags_summary) <- format_parameter_names( + parameters = rownames(runjags_summary), + formula_parameters = unique(unlist(lapply(prior_list, attr, which = "parameter"))), + formula_prefix = formula_prefix) + } + + class(runjags_summary) <- c("BayesTools_table", "BayesTools_runjags_inference", class(runjags_summary)) + attr(runjags_summary, "type") <- c("prior_prob", "post_prob", "inclusion_BF") + attr(runjags_summary, "parameters") <- parameter_names + attr(runjags_summary, "rownames") <- TRUE + attr(runjags_summary, "title") <- title + attr(runjags_summary, "footnotes") <- footnotes + attr(runjags_summary, "warnings") <- warnings return(runjags_summary) } @@ -1169,11 +1330,11 @@ runjags_estimates_empty_table <- function(title = NULL, footnotes = NULL, warnin #' @rdname BayesTools_model_tables runjags_inference_empty_table <- function(title = NULL, footnotes = NULL, warnings = NULL){ - empty_table <- data.frame(matrix(nrow = 0, ncol = 4)) - colnames(empty_table) <- c("Parameter", "prior_prob", "post_prob", "inclusion_BF") + empty_table <- data.frame(matrix(nrow = 0, ncol = 3)) + colnames(empty_table) <- c("prior_prob", "post_prob", "inclusion_BF") - class(empty_table) <- c("BayesTools_table", "BayesTools_runjags_summary", class(empty_table)) - attr(empty_table, "type") <- c("string", "prior_prob", "post_prob", "inclusion_BF") + class(empty_table) <- c("BayesTools_table", "BayesTools_runjags_inference", class(empty_table)) + attr(empty_table, "type") <- c("prior_prob", "post_prob", "inclusion_BF") attr(empty_table, "rownames") <- FALSE attr(empty_table, "title") <- title attr(empty_table, "footnotes") <- footnotes @@ -1264,7 +1425,6 @@ stan_estimates_table <- function(fit, transformations = NULL, title = NULL, foo return(stan_summary) } - #' @title Print a BayesTools table #' #' @param x a BayesTools_values_tables @@ -1451,6 +1611,53 @@ remove_column <- function(table, column_position = NULL){ return(new_table) } +#' @title Updates BayesTools table +#' +#' @description Updates BayesTools table while not breaking formatting, attributes, etc... +#' +#' @param object a BayesTools table +#' @param title title of the table +#' @param footnotes add footnotes to the table +#' @param warnings add warnings of the table +#' @param remove_parameters remove parameters from the table +#' @param logBF whether to format Bayes factors as log(BF) +#' @param BF01 whether to format Bayes factors as 1/BF +#' @param ... additional arguments. +#' +#' @return returns an object of 'BayesTools_table' class. +#' @export +update.BayesTools_table <- function(object, title = NULL, footnotes = NULL, warnings = NULL, remove_parameters = NULL, logBF = FALSE, BF01 = FALSE, ...){ + + check_char(title, "title", allow_NULL = TRUE) + check_char(footnotes, "footnotes", check_length = 0, allow_NULL = TRUE) + check_char(warnings, "warnings", check_length = 0, allow_NULL = TRUE) + check_list(remove_parameters, "remove_parameters", allow_NULL = TRUE) + check_bool(logBF, "logBF") + check_bool(BF01, "BF01") + + if(!is.null(footnotes)){ + attr(object, "footnotes") <- c(attr(object, "footnotes"), footnotes) + } + + if(!is.null(warnings)){ + attr(object, "warnings") <- c(attr(object, "warnings"), warnings) + } + + if(!is.null(remove_parameters)){ + object <- object[rownames(object) %in% remove_parameters,,drop=FALSE] + } + + if(!is.null(title)){ + attr(object, "title") <- title + } + + if(any(attr(object, "type") == "inclusion_BF")){ + object[,which(attr(object, "type") == "inclusion_BF")] <- format_BF(as.numeric(object[,which(attr(object, "type") == "inclusion_BF")]), logBF = logBF, BF01 = BF01, inclusion = TRUE) + } + + return(object) +} + .format_column <- function(x, type, n_models){ if(is.null(x) || length(x) == 0){ return(x) @@ -1555,7 +1762,7 @@ remove_column <- function(table, column_position = NULL){ return(x) } -.check_table_types <- function(x, name, allow_NULL = FALSE){ +.check_table_types <- function(x, name, allow_NULL = FALSE){ check_char(x, name, allow_values = c( "integer", "prior", "string_left", "string", "estimate", "probability", "prior_prob", "post_prob", @@ -1563,3 +1770,63 @@ remove_column <- function(table, column_position = NULL){ "ESS", "R_hat", "MCMC_error", "MCMC_SD_error", "min_ESS", "max_R_hat", "max_MCMC_error", "max_MCMC_SD_error"), allow_NULL = allow_NULL) } +.runjags_summary_fast <- function(model_samples, n_samples, n_chains, conditional){ + + # the chains needs to be kept merged for conditional summary (due to NAs in the chains) + runjags_summary <- cbind.data.frame( + "Mean" = apply(model_samples, 2, mean, na.rm = TRUE), + "SD" = apply(model_samples, 2, stats::sd, na.rm = TRUE), + "lCI" = apply(model_samples, 2, stats::quantile, probs = 0.025, na.rm = TRUE), + "Median" = apply(model_samples, 2, stats::median, na.rm = TRUE), + "uCI" = apply(model_samples, 2, stats::quantile, probs = 0.975, na.rm = TRUE) + ) + + # remove all but Mean for inclusions + runjags_summary[grepl("(inclusion)", rownames(runjags_summary)), c("SD", "lCI", "Median", "uCI")] <- NA + + # don't produce fit diagnostics for conditional samples (different chain lengths etc...) + if(conditional){ + return(runjags_summary) + } + + # split back the chains (allows for diagnostics calculation) + model_samples_list <- split(as.data.frame(model_samples), rep(1:n_chains, each = n_samples), drop = FALSE) + model_samples_list <- coda::as.mcmc.list(lapply(model_samples_list, coda::as.mcmc)) + mcmc_summary <- summary(model_samples_list, quantiles = NULL)$statistics + + # fix single parameter summaries + if(is.null(dim(mcmc_summary))){ + mcmc_summary <- t(mcmc_summary) + } + + # add diagnostics to non-conditional samples + runjags_summary <- cbind.data.frame( + runjags_summary, + "MCMC_error" = mcmc_summary[,"Time-series SE"], + "MCMC_SD_error" = mcmc_summary[,"Time-series SE"] / mcmc_summary[,"SD"], + "ESS" = coda::effectiveSize(model_samples_list), + "R_hat" = if(n_chains > 1) coda::gelman.diag(model_samples_list, multivariate = FALSE, autoburnin = FALSE)$psrf[,1] else NA + ) + + # remove incorrect NANs and NAs from the diagnostics + runjags_summary[is.nan(runjags_summary[,"MCMC_SD_error"]),"MCMC_SD_error"] <- NA + runjags_summary[runjags_summary[,"ESS"] == 0, "ESS"] <- 0 + runjags_summary[is.nan(runjags_summary[,"R_hat"]),"R_hat"] <- NA + + # first omega parameter is always constant + runjags_summary[grepl("omega[0,", rownames(runjags_summary), fixed = TRUE), c("MCMC_error", "MCMC_SD_error", "ESS", "R_hat")] <- NA + + # remove diagnostics for inclusions + runjags_summary[grepl("(inclusion)", rownames(runjags_summary)), c("MCMC_error", "MCMC_SD_error", "ESS", "R_hat")] <- NA + + return(runjags_summary) +} +.runjags_conditional_warning <- function(parameters, n_samples, warning_limit = 500){ + if(n_samples == 0){ + return(sprintf("Conditional summary for %1$s parameter could not be computed due to no posterior samples.", paste0(parameters, collapse = ", "))) + }else if(n_samples <= warning_limit){ + return(sprintf("Conditional summary for %1$s is based on %2$i samples.", paste0(parameters, collapse = ", "), n_samples)) + }else{ + return() + } +} diff --git a/man/BayesTools.Rd b/man/BayesTools.Rd index 62f9dd35..ce670a2a 100644 --- a/man/BayesTools.Rd +++ b/man/BayesTools.Rd @@ -3,7 +3,6 @@ \docType{package} \name{BayesTools} \alias{BayesTools} -\alias{_PACKAGE} \alias{BayesTools-package} \title{BayesTools} \description{ diff --git a/man/BayesTools_model_tables.Rd b/man/BayesTools_model_tables.Rd index 525d7eda..4836c9d6 100644 --- a/man/BayesTools_model_tables.Rd +++ b/man/BayesTools_model_tables.Rd @@ -40,7 +40,8 @@ runjags_estimates_table( transform_orthonormal = FALSE, formula_prefix = TRUE, remove_inclusion = FALSE, - remove_parameters = NULL + remove_parameters = NULL, + return_samples = FALSE ) runjags_inference_table( @@ -63,7 +64,8 @@ JAGS_estimates_table( transform_orthonormal = FALSE, formula_prefix = TRUE, remove_inclusion = FALSE, - remove_parameters = NULL + remove_parameters = NULL, + return_samples = FALSE ) JAGS_inference_table( @@ -156,6 +158,9 @@ differences from the grand mean} \item{remove_inclusion}{whether estimates of the inclusion probabilities should be excluded from the summary table. Defaults to \code{FALSE}.} + +\item{return_samples}{whether to return the transoformed and formated samples +instead of the table. Defaults to \code{FALSE}.} } \value{ \code{model_summary_table} returns a table with diff --git a/man/JAGS_check_convergence.Rd b/man/JAGS_check_convergence.Rd index 647035de..1f92a126 100644 --- a/man/JAGS_check_convergence.Rd +++ b/man/JAGS_check_convergence.Rd @@ -10,7 +10,9 @@ JAGS_check_convergence( max_Rhat = 1.05, min_ESS = 500, max_error = 0.01, - max_SD_error = 0.05 + max_SD_error = 0.05, + add_parameters = NULL, + fail_fast = FALSE ) } \arguments{ @@ -28,6 +30,11 @@ Defaults to \code{1.05}.} \item{max_SD_error}{maximum MCMC error as the proportion of standard deviation of the parameters. Defaults to \code{0.05}.} + +\item{add_parameters}{vector of additional parameter names that should be used +(only allows removing last, fixed, omega element if omega is tracked manually).} + +\item{fail_fast}{whether the function should stop after the first failed convergence check.} } \value{ \code{JAGS_check_convergence} returns a boolean diff --git a/man/as_marginal_inference.Rd b/man/as_marginal_inference.Rd new file mode 100644 index 00000000..1bc74da8 --- /dev/null +++ b/man/as_marginal_inference.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/marginal-distributions.R +\name{as_marginal_inference} +\alias{as_marginal_inference} +\title{Model-average marginal posterior distributions and +marginal Bayes factors based on BayesTools JAGS model via \code{marginal_inference}} +\usage{ +as_marginal_inference( + model, + marginal_parameters, + parameters, + conditional_list, + conditional_rule, + formula, + null_hypothesis = 0, + normal_approximation = FALSE, + n_samples = 10000, + silent = FALSE, + force_plots = FALSE +) +} +\arguments{ +\item{model}{model fit via the \link{JAGS_fit} function} + +\item{marginal_parameters}{parameters for which the the marginal summary +should be created} + +\item{parameters}{all parameters included in the model_list that are +relevant for the formula (all of which need to have specification of +\code{is_null_list})} + +\item{conditional_list}{list of conditional parameters for each marginal parameter} + +\item{conditional_rule}{a character string specifying the rule for conditioning. +Either "AND" or "OR". Defaults to "AND".} + +\item{formula}{model formula (needs to be specified if \code{parameter} was part of a formula)} + +\item{null_hypothesis}{point null hypothesis to test. Defaults to \code{0}} + +\item{normal_approximation}{whether the height of prior and posterior density should be +approximated via a normal distribution (rather than kernel density). Defaults to \code{FALSE}.} + +\item{n_samples}{number of samples to be drawn for the model-averaged +prior distribution} + +\item{silent}{whether warnings should be returned silently. Defaults to \code{FALSE}} + +\item{force_plots}{temporal argument allowing to generate conditional posterior samples +suitable for prior and posterior plots. Only available when conditioning on a +single parameter.} +} +\value{ +\code{as_marginal_inference} returns an object of class 'marginal_inference'. +} +\description{ +Creates marginal model-averaged and conditional +posterior distributions based on a BayesTools JAGS model, vector of parameters, +formula, and a list of conditional specifications for each parameter. +Computes inclusion Bayes factors for each marginal estimate via a Savage-Dickey +density approximation. +} +\seealso{ +\link{marginal_inference} \link{as_mixed_posteriors} +} diff --git a/man/as_mixed_posteriors.Rd b/man/as_mixed_posteriors.Rd new file mode 100644 index 00000000..77bb85c3 --- /dev/null +++ b/man/as_mixed_posteriors.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model-averaging.R +\name{as_mixed_posteriors} +\alias{as_mixed_posteriors} +\title{Export BayesTools JAGS model posterior distribution as model-average posterior distributions via \code{mix_posteriors}} +\usage{ +as_mixed_posteriors( + model, + parameters, + conditional = NULL, + conditional_rule = "AND", + force_plots = FALSE +) +} +\arguments{ +\item{model}{model fit via the \link{JAGS_fit} function} + +\item{parameters}{vector of parameters names for which inference should +be drawn} + +\item{conditional}{a character vector of parameters to be conditioned on} + +\item{conditional_rule}{a character string specifying the rule for conditioning. +Either "AND" or "OR". Defaults to "AND".} + +\item{force_plots}{temporal argument allowing to generate conditional posterior samples +suitable for prior and posterior plots. Only available when conditioning on a +single parameter.} +} +\value{ +\code{as_mix_posteriors} returns a named list of mixed posterior +distributions (either a vector of matrix). +} +\description{ +Creates a model-averages posterior distributions on a single +model that allows mimicking the \link{mix_posteriors} functionality. This function +is useful when the model-averaged ensemble is based on \link{prior_spike_and_slab} +or \link{prior_mixture} priors - the model-averaging is done within the model. +} +\seealso{ +\link{mix_posteriors} +} diff --git a/man/interpret.Rd b/man/interpret.Rd index a170d376..0891cff7 100644 --- a/man/interpret.Rd +++ b/man/interpret.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/interpret.R \name{interpret} \alias{interpret} +\alias{interpret2} \title{Interpret ensemble inference and estimates} \usage{ interpret(inference, samples, specification, method) + +interpret2(specification, method = NULL) } \arguments{ \item{inference}{model inference created by \link{ensemble_inference}} diff --git a/man/is.prior.Rd b/man/is.prior.Rd index 004a0a5c..f23a4da3 100644 --- a/man/is.prior.Rd +++ b/man/is.prior.Rd @@ -16,6 +16,7 @@ \alias{is.prior.independent} \alias{is.prior.spike_and_slab} \alias{is.prior.meandif} +\alias{is.prior.mixture} \title{Reports whether x is a a prior object} \usage{ is.prior(x) @@ -47,6 +48,8 @@ is.prior.independent(x) is.prior.spike_and_slab(x) is.prior.meandif(x) + +is.prior.mixture(x) } \arguments{ \item{x}{an object of test} diff --git a/man/marginal_inference.Rd b/man/marginal_inference.Rd index dfe92a52..e03cd552 100644 --- a/man/marginal_inference.Rd +++ b/man/marginal_inference.Rd @@ -43,15 +43,14 @@ corresponding to the null hypothesis)} approximated via a normal distribution (rather than kernel density). Defaults to \code{FALSE}.} \item{n_samples}{number of samples to be drawn for the model-averaged -posterior distribution} +prior distribution} \item{seed}{seed for random number generation} \item{silent}{whether warnings should be returned silently. Defaults to \code{FALSE}} } \value{ -\code{mix_posteriors} returns a named list of mixed posterior -distributions (either a vector of matrix). +\code{marginal_inference} returns an object of class 'marginal_inference'. } \description{ Creates marginal model-averaged and conditional diff --git a/man/marginal_posterior.Rd b/man/marginal_posterior.Rd index 8bfab341..3b6a1aea 100644 --- a/man/marginal_posterior.Rd +++ b/man/marginal_posterior.Rd @@ -54,7 +54,7 @@ settings the \code{x_seq} or \code{x_range} was specified on the transformed support} \item{n_samples}{number of samples to be drawn for the model-averaged -posterior distribution} +prior distribution} \item{...}{additional arguments} } diff --git a/man/mix_posteriors.Rd b/man/mix_posteriors.Rd index 3f365fe4..998e9f38 100644 --- a/man/mix_posteriors.Rd +++ b/man/mix_posteriors.Rd @@ -46,5 +46,5 @@ indicators of the null or alternative hypothesis models for each parameter. } \seealso{ -\link{ensemble_inference} \link{BayesTools_ensemble_tables} +\link{ensemble_inference} \link{BayesTools_ensemble_tables} \link{as_mixed_posteriors} } diff --git a/man/prior_mixture.Rd b/man/prior_mixture.Rd new file mode 100644 index 00000000..224c830c --- /dev/null +++ b/man/prior_mixture.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{prior_mixture} +\alias{prior_mixture} +\title{Creates a mixture of prior distributions} +\usage{ +prior_mixture( + prior_list, + is_null = rep(FALSE, length(prior_list)), + components = NULL +) +} +\arguments{ +\item{prior_list}{a list of prior distributions to be mixed.} + +\item{is_null}{a logical vector indicating which of the prior distributions +should be considered as a null distribution. Defaults to \code{rep(FALSE, length(prior_list))}.} + +\item{components}{a character vector indicating which of the prior distributions +belong to the same mixture component (this is an alternative specification to the \code{is_null} argument). +Defaults to \code{NULL} (i.e., \code{is_null} is used.} +} +\description{ +\code{prior_mixture} creates a mixture of prior distributions. +This is a more generic version of the \code{prior_spike_and_slab} function. +} +\seealso{ +\code{\link[=prior]{prior()}} +} diff --git a/man/prior_weightfunction.Rd b/man/prior_weightfunction.Rd index 653630e7..c524feb1 100644 --- a/man/prior_weightfunction.Rd +++ b/man/prior_weightfunction.Rd @@ -42,6 +42,14 @@ its prior distributions.} \code{prior_weightfunction} creates a prior distribution for fitting a RoBMA selection model. The prior can be visualized by the \code{plot} function. } +\details{ +Constrained cases of weight functions can be specified by adding +".fixed" after the distribution name, i.e., \code{"two.sided.fixed"} and +\code{"one.sided.fixed"}. In these cases, the functions are specified using +\code{steps} and \code{omega} parameters, where the \code{omega} parameter +is a vector of weights that corresponds to the relative publication probability +(i.e., no parameters are estimated). +} \examples{ p1 <- prior_weightfunction("one-sided", parameters = list(steps = c(.05, .10), alpha = c(1, 1, 1))) diff --git a/man/update.BayesTools_table.Rd b/man/update.BayesTools_table.Rd new file mode 100644 index 00000000..9868e8f1 --- /dev/null +++ b/man/update.BayesTools_table.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary-tables.R +\name{update.BayesTools_table} +\alias{update.BayesTools_table} +\title{Updates BayesTools table} +\usage{ +\method{update}{BayesTools_table}( + object, + title = NULL, + footnotes = NULL, + warnings = NULL, + remove_parameters = NULL, + logBF = FALSE, + BF01 = FALSE, + ... +) +} +\arguments{ +\item{object}{a BayesTools table} + +\item{title}{title of the table} + +\item{footnotes}{add footnotes to the table} + +\item{warnings}{add warnings of the table} + +\item{remove_parameters}{remove parameters from the table} + +\item{logBF}{whether to format Bayes factors as log(BF)} + +\item{BF01}{whether to format Bayes factors as 1/BF} + +\item{...}{additional arguments.} +} +\value{ +returns an object of 'BayesTools_table' class. +} +\description{ +Updates BayesTools table while not breaking formatting, attributes, etc... +} diff --git a/man/weightfunctions_mapping.Rd b/man/weightfunctions_mapping.Rd index a3c7acd9..d7087ebc 100644 --- a/man/weightfunctions_mapping.Rd +++ b/man/weightfunctions_mapping.Rd @@ -4,12 +4,14 @@ \alias{weightfunctions_mapping} \title{Create coefficient mapping between multiple weightfunctions} \usage{ -weightfunctions_mapping(prior_list, cuts_only = FALSE) +weightfunctions_mapping(prior_list, cuts_only = FALSE, one_sided = FALSE) } \arguments{ \item{prior_list}{list of prior distributions} \item{cuts_only}{whether only p-value cuts should be returned} + +\item{one_sided}{force one-sided output} } \value{ \code{weightfunctions_mapping} returns a list of indices diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-1.svg index 09d4ba1b..ed99d457 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-1.svg @@ -47,10 +47,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-1.svg index 94da3008..59eeadc2 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-1.svg @@ -49,10 +49,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-2.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-2.svg index b4c7751f..25c915c2 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-2.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-2.svg @@ -47,10 +47,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-3.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-3.svg index 2b8331d4..c2278f9b 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-3.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-2-3.svg @@ -51,10 +51,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-1.svg index 2bc19689..3b4bf1e9 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-1.svg @@ -47,10 +47,10 @@ - - - - + + + + 0.0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-2.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-2.svg index 32270e7a..a20f760d 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-2.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-ggplot-density-3-2.svg @@ -47,10 +47,10 @@ - - - - + + + + 0.0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-1.svg index c8fb2b9a..544a964c 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-1.svg @@ -33,19 +33,19 @@ 0.5 0.6 0.7 - + - - - - - + + + + + 0 -1 -2 -3 -4 -5 +1 +2 +3 +4 +5 Normal (0, 1) x_cont1 @@ -57,9 +57,9 @@ - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-2.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-2.svg index f11a56f2..c4c675f8 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-2.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-2.svg @@ -29,15 +29,15 @@ 1.6 1.8 2.0 - + - - - + + + 0 -1 -2 -3 +1 +2 +3 Normal (0, 1) x_cont1 @@ -49,9 +49,9 @@ - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-3.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-3.svg index 35d5cf34..eff7701e 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-3.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-3.svg @@ -31,21 +31,21 @@ 0.2 0.4 0.6 - + - - - - - - + + + + + + 0.0 -0.5 -1.0 -1.5 -2.0 -2.5 -3.0 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 Treatment Values Smth @@ -56,9 +56,9 @@ - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-4.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-4.svg index fad43a61..de4b5b23 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-4.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-4.svg @@ -29,23 +29,23 @@ 0.4 0.6 0.8 - + - - - - - - - + + + + + + + 0.0 -0.5 -1.0 -1.5 -2.0 -2.5 -3.0 -3.5 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 @@ -65,10 +65,10 @@ - - - - + + + + @@ -89,23 +89,23 @@ 0.0 0.2 0.4 - + - - - - - - - + + + + + + + 0.0 -0.5 -1.0 -1.5 -2.0 -2.5 -3.0 -3.5 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 @@ -120,9 +120,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-5.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-5.svg index a4ab971a..c74b6fc4 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-5.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-5.svg @@ -27,17 +27,17 @@ 0.0 0.2 0.4 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -57,10 +57,10 @@ - - - - + + + + @@ -79,17 +79,17 @@ -0.2 0.0 0.2 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -104,10 +104,10 @@ Density - - - - + + + + @@ -128,17 +128,17 @@ 0.2 0.4 0.6 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -153,9 +153,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-6.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-6.svg index c4143e84..afae1607 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-6.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-6.svg @@ -29,15 +29,15 @@ 2 3 4 - + - - - + + + 0.0 -0.2 -0.4 -0.6 +0.2 +0.4 +0.6 PET ~ Gamma (2, 2) @@ -50,9 +50,9 @@ - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-7.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-7.svg index 6ba1c675..457a58ee 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-7.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-7.svg @@ -31,15 +31,15 @@ 0.6 0.8 1.0 - + - - - + + + 0.0 -0.5 -1.0 -1.5 +0.5 +1.0 +1.5 @@ -66,10 +66,10 @@ - - - - + + + + @@ -92,15 +92,15 @@ 0.6 0.8 1.0 - + - - - + + + 0.0 -0.5 -1.0 -1.5 +0.5 +1.0 +1.5 @@ -122,9 +122,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-8.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-8.svg index ae34f2b9..a0c015cc 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-8.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-density-8.svg @@ -27,17 +27,17 @@ -1 0 1 - + - - - - + + + + 0.0 -0.2 -0.4 -0.6 -0.8 +0.2 +0.4 +0.6 +0.8 @@ -57,10 +57,10 @@ - - - - + + + + @@ -81,17 +81,17 @@ 0 1 2 - + - - - - + + + + 0.0 -0.2 -0.4 -0.6 -0.8 +0.2 +0.4 +0.6 +0.8 @@ -106,9 +106,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-spike-and-slab-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-spike-and-slab-1.svg index 733e2a57..c965da04 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-spike-and-slab-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics-plot-spike-and-slab-1.svg @@ -29,17 +29,17 @@ 0.2 0.3 0.4 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 Normal (0, 1) @@ -56,9 +56,9 @@ - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-1.svg index 9c35418f..01b55eca 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-1.svg @@ -49,10 +49,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-2.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-2.svg index 50291aee..638aebe8 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-2.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-1-2.svg @@ -49,10 +49,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-1.svg index fea7c4a7..855e7fd6 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-1.svg @@ -47,10 +47,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-2.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-2.svg index e2c30db7..b0875772 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-2.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-2.svg @@ -47,10 +47,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-3.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-3.svg index 9e7adb08..cb0c9462 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-3.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-ggplot-density-2-3.svg @@ -47,10 +47,10 @@ - - - - + + + + 0 diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-1.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-1.svg index 7fbd0e07..9a73e7b3 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-1.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-1.svg @@ -27,17 +27,17 @@ 0.0 0.2 0.4 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -57,10 +57,10 @@ - - - - + + + + @@ -79,17 +79,17 @@ 0.0 0.2 0.4 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -104,9 +104,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-2.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-2.svg index 3e56c6a6..f1205314 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-2.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-2.svg @@ -29,17 +29,17 @@ 0.2 0.4 0.6 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -59,10 +59,10 @@ - - - - + + + + @@ -81,17 +81,17 @@ -0.2 0.0 0.2 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -106,9 +106,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-3.svg b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-3.svg index b7ee3a98..e3afae4a 100644 --- a/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-3.svg +++ b/tests/testthat/_snaps/JAGS-diagnostics/diagnostics3-plot-density-3.svg @@ -27,17 +27,17 @@ -0.2 0.0 0.2 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -57,10 +57,10 @@ - - - - + + + + @@ -81,17 +81,17 @@ -0.2 0.0 0.2 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -106,10 +106,10 @@ Density - - - - + + + + @@ -130,17 +130,17 @@ 0.2 0.4 0.6 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 @@ -155,9 +155,9 @@ Density - - - - + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-mixture-1.svg b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-mixture-1.svg new file mode 100644 index 00000000..ae212c0f --- /dev/null +++ b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-mixture-1.svg @@ -0,0 +1,297 @@ + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 + + +Intercept indicator + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + +1 +2 + + +x_cont1 indicator + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 + + + + + + + + + + + +1 +2 + + +sigma indicator + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 + + + + + + + + + + + + + + +mu_intercept +posterior1[, "mu_intercept"] +Density + + + + + + + +-0.3 +-0.2 +-0.1 +0.0 + + + + + + +0 +5 +10 +15 +20 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 +posterior1[, "mu_x_cont1"] +Density + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + +sigma +posterior1[, "sigma"] +Density + + + + + + + + + +0.70 +0.75 +0.80 +0.85 +0.90 +0.95 + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-mixture-2.svg b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-mixture-2.svg new file mode 100644 index 00000000..65510902 --- /dev/null +++ b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-mixture-2.svg @@ -0,0 +1,362 @@ + + + + + + + + + + + + + + + + + + + +x_fac3t[A] +temp_samples[, 1] +Density + + + + + + + + + +-0.3 +-0.2 +-0.1 +0.0 +0.1 +0.2 + + + + + + +0 +2 +4 +6 +8 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_fac3t[B] +temp_samples[, 2] +Density + + + + + + + + + + +-0.5 +-0.4 +-0.3 +-0.2 +-0.1 +0.0 +0.1 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_fac3t[C] +temp_samples[, 3] +Density + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_fac3t_variable[A] +temp_samples_variable[, 1] +Density + + + + + + + + + + +-3 +-2 +-1 +0 +1 +2 +3 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_fac3t_variable[B] +temp_samples_variable[, 2] +Density + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + +0.0 +0.5 +1.0 +1.5 + + + + + + + + + + + + + + + + + + + + + + + + + + +x_fac3t_variable[C] +temp_samples_variable[, 3] +Density + + + + + + + + + + +-3 +-2 +-1 +0 +1 +2 +3 + + + + + +0.0 +0.5 +1.0 +1.5 + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-1.svg b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-1.svg index 3284ec03..32775026 100644 --- a/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-1.svg +++ b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-1.svg @@ -41,17 +41,17 @@ 0.2 0.3 0.4 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 @@ -59,15 +59,15 @@ - - - - + + + + - - - - + + + + @@ -87,46 +87,60 @@ Density - + - - - - + + + + + - --4 --3 --2 --1 -0 -1 -2 - + +-2.0 +-1.5 +-1.0 +-0.5 +0.0 +0.5 +1.0 +1.5 + - - - - + + + + + + + 0.0 -0.5 -1.0 -1.5 -2.0 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 +3.5 - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + @@ -159,38 +173,38 @@ 0.6 0.8 1.0 - + - - - - + + + + 0.0 -0.5 -1.0 -1.5 -2.0 +0.5 +1.0 +1.5 +2.0 - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-2.svg b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-2.svg index bf825159..c4c5562c 100644 --- a/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-2.svg +++ b/tests/testthat/_snaps/JAGS-fit/jags-fit-formula-spike-and-slab-2.svg @@ -30,36 +30,30 @@ Density - - - - - - - - --0.3 --0.2 --0.1 -0.0 -0.1 -0.2 -0.3 - + + + + + + + +-0.3 +-0.2 +-0.1 +0.0 +0.1 +0.2 + - - - - - - + + + + 0 -1 -2 -3 -4 -5 -6 +2 +4 +6 +8 @@ -67,19 +61,17 @@ - - - - - - - - - - - - - + + + + + + + + + + + @@ -99,48 +91,43 @@ Density - - - - - - - - --0.6 --0.5 --0.4 --0.3 --0.2 --0.1 -0.0 - + + + + + + + +-0.4 +-0.3 +-0.2 +-0.1 +0.0 +0.1 + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 - - - - - - - - - - - - - - + + + + + + + + + + + @@ -160,47 +147,45 @@ Density - - - - - - - + + + + + + -0.0 -0.1 -0.2 -0.3 -0.4 -0.5 -0.6 - +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 + - - - - + + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 +5 - - - - - - - - - - - - - + + + + + + + + + + + @@ -220,45 +205,48 @@ Density - - - - - - + + + + + + + --2 --1 -0 -1 -2 +-3 +-2 +-1 +0 +1 +2 3 - + - - - - - + + + + + 0.0 -0.2 -0.4 -0.6 -0.8 -1.0 +0.2 +0.4 +0.6 +0.8 +1.0 - - - - - - - - - - - + + + + + + + + + + + + @@ -293,29 +281,29 @@ 1 2 3 - + - - - + + + 0.0 -0.5 -1.0 -1.5 +0.5 +1.0 +1.5 - - - - - + + + + + - - - - - - + + + + + + @@ -350,29 +338,29 @@ 1 2 3 - + - - - + + + 0.0 -0.5 -1.0 -1.5 +0.5 +1.0 +1.5 - - - - - - - + + + + + + + - - - - - + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-1.svg b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-1.svg new file mode 100644 index 00000000..e5833c9c --- /dev/null +++ b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-1.svg @@ -0,0 +1,201 @@ + + + + + + + + + + + + +( +1 +/ +7 +) + +* + +Normal +(0, 1) + ++ + +( +5 +/ +7 +) + +* + +Normal +(-3, 1) + ++ + +( +1 +/ +7 +) + +* + +Gamma +(5, 10) +temp_samples +Density + + + + + + +-6 +-4 +-2 +0 +2 + + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-2.svg b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-2.svg new file mode 100644 index 00000000..642e2dbc --- /dev/null +++ b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-2.svg @@ -0,0 +1,181 @@ + + + + + + + + + + + + +( +1 +/ +6 +) + +* + +Normal +(0, 1) + ++ + +( +5 +/ +6 +) + +* + +Normal +(-3, 1) +temp_samples +Density + + + + + + +-6 +-4 +-2 +0 +2 + + + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 +0.35 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-3.svg b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-3.svg new file mode 100644 index 00000000..6b4a5101 --- /dev/null +++ b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-3.svg @@ -0,0 +1,169 @@ + + + + + + + + + + + + +( +1 +/ +2 +) + +* + +Spike +(2) + ++ + +( +1 +/ +2 +) + +* + +Normal +(-3, 1) +temp_samples +Density + + + + + + +-6 +-4 +-2 +0 +2 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-4.svg b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-4.svg new file mode 100644 index 00000000..85e51958 --- /dev/null +++ b/tests/testthat/_snaps/JAGS-fit/jags-model-prior-mixture-4.svg @@ -0,0 +1,711 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 + + +Bias componenets + + + + + + + + + +0.00 +0.10 +0.20 + + + + + + + + + + + + + + +PET +samples_PET[samples_PET != 0 & samples_PET < 10] +Density + + + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + +0.0 +0.2 +0.4 +0.6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +PEESE +samples_PEESE[samples_PEESE != 0 & samples_PEESE < 20] +Density + + + + + + + + +0 +5 +10 +15 +20 + + + + + +0.00 +0.05 +0.10 +0.15 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[2:1] +samples_omega[samples_bias == 2, 1] +Density + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + + + + + + + + + +omega[2:2] +samples_omega[samples_bias == 2, 2] +Density + + + + + + + + +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[2:3] +samples_omega[samples_bias == 2, 3] +Density + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[2:4] +samples_omega[samples_bias == 2, 4] +Density + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[2:5] +samples_omega[samples_bias == 2, 5] +Density + + + + + + + + +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[2:6] +samples_omega[samples_bias == 2, 6] +Density + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + diff --git a/tests/testthat/_snaps/JAGS-fit/jags-model-weightfunction-3.svg b/tests/testthat/_snaps/JAGS-fit/jags-model-weightfunction-3.svg index 4c65a9e0..d7a567a7 100644 --- a/tests/testthat/_snaps/JAGS-fit/jags-model-weightfunction-3.svg +++ b/tests/testthat/_snaps/JAGS-fit/jags-model-weightfunction-3.svg @@ -133,7 +133,7 @@ - + @@ -233,7 +233,7 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-cont1.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-cont1.svg index 9bc322bc..6eb9b04f 100644 --- a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-cont1.svg +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-cont1.svg @@ -49,12 +49,12 @@ - - - - - - + + + + + + 0 @@ -82,24 +82,24 @@ 0.8 1.0 Density - - - - - - - - - - - - - - - - --1SD -0SD -1SD + + + + + + + + + + + + + + + + +-1SD +0SD +1SD diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-1.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-1.svg index 3add2417..a98e2b26 100644 --- a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-1.svg +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-1.svg @@ -49,8 +49,8 @@ - - + + 0 @@ -78,12 +78,12 @@ 0.8 0.9 Density - - - - - -A -B + + + + + +A +B diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-2.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-2.svg index ec55985a..f98ed787 100644 --- a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-2.svg +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-2.svg @@ -49,8 +49,8 @@ - - + + 0 @@ -79,12 +79,12 @@ 0.9 fac2t Density - - - - - -A -B + + + + + +A +B diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-3.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-3.svg index 41d7d4e6..3cacfdd7 100644 --- a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-3.svg +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-3.svg @@ -51,10 +51,10 @@ - - - - + + + + 0 @@ -84,16 +84,16 @@ 6 8 Density - - - - - - - - - -A -B + + + + + + + + + +A +B diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-4.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-4.svg index 92398968..0b35d071 100644 --- a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-4.svg +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac2t-4.svg @@ -47,10 +47,10 @@ - - - - + + + + 0 @@ -76,16 +76,16 @@ 0.8 1.0 Density - - - - - - - - - -A -B + + + + + + + + + +A +B diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac3md.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac3md.svg index ed171fbd..1e4aace3 100644 --- a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac3md.svg +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-mu-x-fac3md.svg @@ -18,7 +18,7 @@ - + @@ -45,12 +45,12 @@ - - - - - - + + + + + + 0 @@ -74,24 +74,24 @@ 0.5 1.0 Density - - - - - - - - - - - - - - - - -A -B -C + + + + + + + + + + + + + + + + +A +B +C diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-cont1.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-cont1.svg new file mode 100644 index 00000000..a87d8cc3 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-cont1.svg @@ -0,0 +1,109 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 +Density + + + + + + + + + + + + + + + + +-1SD +0SD +1SD + + diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-1.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-1.svg new file mode 100644 index 00000000..da133bd0 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-1.svg @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + + + + + + +0.4 +0.5 +0.6 +0.7 +0.8 +Density + + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-2.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-2.svg new file mode 100644 index 00000000..6b5e4e11 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-2.svg @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + + + + + + +0.4 +0.5 +0.6 +0.7 +0.8 +fac2t +Density + + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-3.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-3.svg new file mode 100644 index 00000000..9aaf58c0 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-3.svg @@ -0,0 +1,107 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + + + + + + + + + +-6 +-4 +-2 +0 +2 +4 +6 +8 +Density + + + + + + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-4.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-4.svg new file mode 100644 index 00000000..a35fa4cf --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac2t-4.svg @@ -0,0 +1,99 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 +Density + + + + + + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac3md.svg b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac3md.svg new file mode 100644 index 00000000..f981e29e --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/ggplot-marginal-ss-mu-x-fac3md.svg @@ -0,0 +1,105 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 +Density + + + + + + + + + + + + + + + + +A +B +C + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-con-exp.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-con-exp.svg index ff2b8339..bba0357d 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-con-exp.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-con-exp.svg @@ -77,7 +77,7 @@ - + @@ -136,7 +136,7 @@ - + @@ -208,6 +208,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-con-p-exp.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-con-p-exp.svg index 1f6236fe..47794cdd 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-con-p-exp.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-con-p-exp.svg @@ -146,7 +146,7 @@ - + @@ -275,7 +275,7 @@ - + @@ -406,6 +406,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-con.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-con.svg index 235c57ce..f3641cdc 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-con.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-con.svg @@ -78,7 +78,7 @@ - + @@ -144,7 +144,7 @@ - + @@ -203,6 +203,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md-at.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md-at.svg index bdbcdf2b..1bfd629c 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md-at.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md-at.svg @@ -72,7 +72,7 @@ - + @@ -127,7 +127,7 @@ - + @@ -185,7 +185,7 @@ - + @@ -244,7 +244,7 @@ - + @@ -304,7 +304,7 @@ - + @@ -364,6 +364,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md.svg index c8e16c44..fa73ae0e 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-md.svg @@ -78,7 +78,7 @@ - + @@ -143,7 +143,7 @@ - + @@ -208,6 +208,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-mdi.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-mdi.svg index 9d361901..6d38ffab 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-mdi.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-mdi.svg @@ -76,7 +76,7 @@ - + @@ -140,7 +140,7 @@ - + @@ -200,7 +200,7 @@ - + @@ -264,7 +264,7 @@ - + @@ -330,7 +330,7 @@ - + @@ -396,7 +396,7 @@ - + @@ -454,7 +454,7 @@ - + @@ -513,7 +513,7 @@ - + @@ -574,6 +574,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-t.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-t.svg index 306e8f45..a2dbdb5a 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-t.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-fac-t.svg @@ -80,7 +80,7 @@ - + @@ -145,6 +145,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-form-int.svg b/tests/testthat/_snaps/marginal-distributions/marginal-form-int.svg index 8236ea72..e0dbc187 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-form-int.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-form-int.svg @@ -71,6 +71,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont-p.svg index 2b8aef78..af927343 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont-p.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont-p.svg @@ -139,7 +139,7 @@ - + @@ -263,7 +263,7 @@ - + @@ -387,6 +387,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont.svg index b49a3859..71ac0c4c 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-cont.svg @@ -92,7 +92,7 @@ - + @@ -157,7 +157,7 @@ - + @@ -228,6 +228,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md-p.svg index ba9aba18..b9ef91d0 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md-p.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md-p.svg @@ -139,7 +139,7 @@ - + @@ -263,7 +263,7 @@ - + @@ -387,6 +387,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md.svg index 96ee1824..788ea144 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-fac-md.svg @@ -78,7 +78,7 @@ - + @@ -143,7 +143,7 @@ - + @@ -208,6 +208,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-cont-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-cont-p.svg new file mode 100644 index 00000000..ade6ff85 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-cont-p.svg @@ -0,0 +1,392 @@ + + + + + + + + + + + + + + + + + + + +mu_x_cont1 = -1SD +attr(marg_post_x_cont1[["-1SD"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +mu_x_cont1 = 0SD +attr(marg_post_x_cont1[["0SD"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +mu_x_cont1 = 1SD +attr(marg_post_x_cont1[["1SD"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-cont.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-cont.svg new file mode 100644 index 00000000..99590152 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-cont.svg @@ -0,0 +1,235 @@ + + + + + + + + + + + + + + + + + + + +mu_x_cont1 = -1SD +marg_post_x_cont1[["-1SD"]] +Density + + + + + + + + + +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + + + +0 +1 +2 +3 +4 +5 +6 +7 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +mu_x_cont1 = 0SD +marg_post_x_cont1[["0SD"]] +Density + + + + + + + + + + +0.45 +0.50 +0.55 +0.60 +0.65 +0.70 +0.75 + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +mu_x_cont1 = +1SD +marg_post_x_cont1[["1SD"]] +Density + + + + + + + + + +0.6 +0.7 +0.8 +0.9 +1.0 +1.1 + + + + + +0 +2 +4 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-fac-md-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-fac-md-p.svg new file mode 100644 index 00000000..f928ba81 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-fac-md-p.svg @@ -0,0 +1,392 @@ + + + + + + + + + + + + + + + + + + + +marginal prior x_fac3md = A +attr(marg_post_x_fac3md[["A"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_fac3md = B +attr(marg_post_x_fac3md[["B"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_fac3md = C +attr(marg_post_x_fac3md[["C"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-fac-md.svg b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-fac-md.svg new file mode 100644 index 00000000..e25d7b3b --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-inference-ss-fac-md.svg @@ -0,0 +1,233 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = A +marg_post_x_fac3md[["A"]] +Density + + + + + + + + + +0.5 +0.6 +0.7 +0.8 +0.9 +1.0 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = B +marg_post_x_fac3md[["B"]] +Density + + + + + + + + + + +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = C +marg_post_x_fac3md[["C"]] +Density + + + + + + + + + +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-prior-ind.svg b/tests/testthat/_snaps/marginal-distributions/marginal-prior-ind.svg index 1e4f2ed6..1fc61153 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-prior-ind.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-prior-ind.svg @@ -41,15 +41,15 @@ 1 2 3 - + - - - + + + 0 -1 -2 -3 +1 +2 +3 @@ -61,42 +61,42 @@ - - - - - - + + + + + + - - - - - - - + + + + + + + - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + - + @@ -129,33 +129,33 @@ 1 2 3 - + - - - + + + 0 -1 -2 -3 +1 +2 +3 - - - - - - + + + + + + - - - - - + + + + + @@ -165,17 +165,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -213,58 +213,58 @@ 1 2 3 - + - - - + + + 0 -1 -2 -3 +1 +2 +3 - - - + + + - - - - + + + + - - - - - + + + + + - + - - + + - - - - - - - - - - + + + + + + + + + + - - - + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-prior-trt.svg b/tests/testthat/_snaps/marginal-distributions/marginal-prior-trt.svg index d34f1a74..a04f5b39 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-prior-trt.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-prior-trt.svg @@ -96,24 +96,24 @@ - + - - + + - - - - + + + + - + @@ -206,32 +206,32 @@ - + - + - + - + - + - + - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-prior-weightfunction.svg b/tests/testthat/_snaps/marginal-distributions/marginal-prior-weightfunction.svg index 717fb409..1a1bb395 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-prior-weightfunction.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-prior-weightfunction.svg @@ -159,7 +159,7 @@ 25 - + @@ -169,8 +169,8 @@ - - + + @@ -187,7 +187,7 @@ - + @@ -200,10 +200,10 @@ - + - + @@ -256,7 +256,7 @@ 25 - + @@ -266,8 +266,8 @@ - - + + @@ -284,7 +284,7 @@ - + @@ -297,10 +297,10 @@ - + - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-simple-con.svg b/tests/testthat/_snaps/marginal-distributions/marginal-simple-con.svg index 6ec9e760..af58a247 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-simple-con.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-simple-con.svg @@ -68,6 +68,6 @@ - + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-simple-fac.svg b/tests/testthat/_snaps/marginal-distributions/marginal-simple-fac.svg index 81edc998..73d4b37a 100644 --- a/tests/testthat/_snaps/marginal-distributions/marginal-simple-fac.svg +++ b/tests/testthat/_snaps/marginal-distributions/marginal-simple-fac.svg @@ -142,7 +142,7 @@ - - + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-cond-fac.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-cond-fac.svg new file mode 100644 index 00000000..6068a767 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-cond-fac.svg @@ -0,0 +1,384 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = A +marg_post_sigma[["A"]] +Density + + + + + + + + + +0.5 +0.6 +0.7 +0.8 +0.9 +1.0 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = B +marg_post_sigma[["B"]] +Density + + + + + + + + + + +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = C +marg_post_sigma[["C"]] +Density + + + + + + + + + +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = A +attr(marg_post_sigma[["A"]], "prior") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + +0.0 +0.1 +0.2 +0.3 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = B +attr(marg_post_sigma[["B"]], "prior") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + +0.0 +0.1 +0.2 +0.3 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = C +attr(marg_post_sigma[["C"]], "prior") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + +0.0 +0.1 +0.2 +0.3 + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-exp.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-exp.svg new file mode 100644 index 00000000..89882a21 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-exp.svg @@ -0,0 +1,209 @@ + + + + + + + + + + + + + + + + + + + +exp marginal posterior x_cont1 +(-1) +marg_post_x_cont1.exp[["-1SD"]] +Density + + + + + + + + +1.2 +1.4 +1.6 +1.8 +2.0 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +exp marginal posterior x_cont1 +(0) +marg_post_x_cont1.exp[["0SD"]] +Density + + + + + + + + + + +1.6 +1.7 +1.8 +1.9 +2.0 +2.1 +2.2 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +exp marginal posterior x_cont1 +(1) +marg_post_x_cont1.exp[["1SD"]] +Density + + + + + + + + + +1.8 +2.0 +2.2 +2.4 +2.6 +2.8 + + + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +2.5 +3.0 + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-p-exp.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-p-exp.svg new file mode 100644 index 00000000..d494ef4b --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-p-exp.svg @@ -0,0 +1,407 @@ + + + + + + + + + + + + + + + + + + + +marginal prior x_cont1 +(-1) +attr(marg_post_x_cont1.exp[["-1SD"]], "prior_samples") +Density + + + + + + + + +-10 +-5 +0 +5 +10 + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_cont1 +(0) +exp(attr(marg_post_x_cont1[["0SD"]], "prior_samples")) +Density + + + + + + + + +-10 +-5 +0 +5 +10 + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_cont1 +(1) +attr(marg_post_x_cont1.exp[["1SD"]], "prior_samples") +Density + + + + + + + + +-10 +-5 +0 +5 +10 + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-p.svg new file mode 100644 index 00000000..389ffce8 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con-p.svg @@ -0,0 +1,404 @@ + + + + + + + + + + + + + + + + + + + +marginal prior x_cont1 +(-1) +attr(marg_post_x_cont1[["-1SD"]], "prior_samples") +Density + + + + + + + + +-10 +-5 +0 +5 +10 + + + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 +0.35 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_cont1 +(0) +attr(marg_post_x_cont1[["0SD"]], "prior_samples") +Density + + + + + + + + +-10 +-5 +0 +5 +10 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_cont1 +(1) +attr(marg_post_x_cont1[["1SD"]], "prior_samples") +Density + + + + + + + + +-10 +-5 +0 +5 +10 + + + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 +0.35 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con.svg new file mode 100644 index 00000000..fafdf87d --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-con.svg @@ -0,0 +1,209 @@ + + + + + + + + + + + + + + + + + + + +marginal posterior x_cont1 +(-1) +marg_post_x_cont1[["-1SD"]] +Density + + + + + + + + + +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal posterior x_cont1 +(0) +marg_post_x_cont1[["0SD"]] +Density + + + + + + + + + + +0.45 +0.50 +0.55 +0.60 +0.65 +0.70 +0.75 + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal posterior x_cont1 +(1) +marg_post_x_cont1[["1SD"]] +Density + + + + + + + + + +0.6 +0.7 +0.8 +0.9 +1.0 +1.1 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md-at.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md-at.svg new file mode 100644 index 00000000..eac143ee --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md-at.svg @@ -0,0 +1,376 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = A | 1,A +marg_post_x_fac3md_AT[["A"]][1, ] +Density + + + + + + + + + + + +0.6 +0.7 +0.8 +0.9 +1.0 +1.1 +1.2 +1.3 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = A | 1,B +marg_post_x_fac3md_AT[["A"]][2, ] +Density + + + + + + + + + + + +0.6 +0.7 +0.8 +0.9 +1.0 +1.1 +1.2 +1.3 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = B | 1,A +marg_post_x_fac3md_AT[["B"]][1, ] +Density + + + + + + + +0.4 +0.6 +0.8 +1.0 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = B | 1,B +marg_post_x_fac3md_AT[["B"]][2, ] +Density + + + + + + + +0.4 +0.6 +0.8 +1.0 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = C | 1,A +marg_post_x_fac3md_AT[["C"]][1, ] +Density + + + + + + + + +0.4 +0.6 +0.8 +1.0 +1.2 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = C | 1,B +marg_post_x_fac3md_AT[["C"]][2, ] +Density + + + + + + + + +0.4 +0.6 +0.8 +1.0 +1.2 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md-p.svg new file mode 100644 index 00000000..8e7a4800 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md-p.svg @@ -0,0 +1,392 @@ + + + + + + + + + + + + + + + + + + + +marginal prior x_fac3md = A +attr(marg_post_x_fac3md[["A"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_fac3md = B +attr(marg_post_x_fac3md[["B"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_fac3md = C +attr(marg_post_x_fac3md[["C"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md.svg new file mode 100644 index 00000000..71b9ce73 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-md.svg @@ -0,0 +1,230 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = A +marg_post_x_fac3md[["A"]] +Density + + + + + + + + + +0.5 +0.6 +0.7 +0.8 +0.9 +1.0 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac3md = B +marg_post_x_fac3md[["B"]] +Density + + + + + + + + + + +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = B +marg_post_x_fac3md[["C"]] +Density + + + + + + + + + +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-mdi-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-mdi-p.svg new file mode 100644 index 00000000..47e7c764 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-mdi-p.svg @@ -0,0 +1,1145 @@ + + + + + + + + + + + + + + + + + + + +x_cont1 = -1 +marg_post_x_fac3md = A +attr(marg_post_x_cont1__xXx__x_fac3md[["-1SD, A"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = -1 +marg_post_x_fac3md = B +attr(marg_post_x_cont1__xXx__x_fac3md[["-1SD, B"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = -1 +marg_post_x_fac3md = B +attr(marg_post_x_cont1__xXx__x_fac3md[["-1SD, C"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 0 +marg_post_x_fac3md = A +attr(marg_post_x_cont1__xXx__x_fac3md[["0SD, A"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 0 +marg_post_x_fac3md = B +attr(marg_post_x_cont1__xXx__x_fac3md[["0SD, B"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 0 +marg_post_x_fac3md = B +attr(marg_post_x_cont1__xXx__x_fac3md[["0SD, C"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 1 +marg_post_x_fac3md = A +attr(marg_post_x_cont1__xXx__x_fac3md[["1SD, A"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 1 +marg_post_x_fac3md = B +attr(marg_post_x_cont1__xXx__x_fac3md[["1SD, B"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 1 +marg_post_x_fac3md = B +attr(marg_post_x_cont1__xXx__x_fac3md[["1SD, C"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-mdi.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-mdi.svg new file mode 100644 index 00000000..bc6e84c7 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-mdi.svg @@ -0,0 +1,595 @@ + + + + + + + + + + + + + + + + + + + +x_cont1 = -1 +marg_post_x_fac3md = A +marg_post_x_cont1__xXx__x_fac3md[["-1SD, A"]] +Density + + + + + + + +0.2 +0.4 +0.6 +0.8 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = -1 +marg_post_x_fac3md = B +marg_post_x_cont1__xXx__x_fac3md[["-1SD, B"]] +Density + + + + + + + +0.0 +0.2 +0.4 +0.6 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = -1 +marg_post_x_fac3md = B +marg_post_x_cont1__xXx__x_fac3md[["-1SD, C"]] +Density + + + + + + + + + + +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 0 +marg_post_x_fac3md = A +marg_post_x_cont1__xXx__x_fac3md[["0SD, A"]] +Density + + + + + + + + + +0.5 +0.6 +0.7 +0.8 +0.9 +1.0 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 0 +marg_post_x_fac3md = B +marg_post_x_cont1__xXx__x_fac3md[["0SD, B"]] +Density + + + + + + + + + + +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 0 +marg_post_x_fac3md = B +marg_post_x_cont1__xXx__x_fac3md[["0SD, C"]] +Density + + + + + + + + + +0.3 +0.4 +0.5 +0.6 +0.7 +0.8 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 1 +marg_post_x_fac3md = A +marg_post_x_cont1__xXx__x_fac3md[["1SD, A"]] +Density + + + + + + + + + + + +0.6 +0.7 +0.8 +0.9 +1.0 +1.1 +1.2 +1.3 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 1 +marg_post_x_fac3md = B +marg_post_x_cont1__xXx__x_fac3md[["1SD, B"]] +Density + + + + + + + +0.4 +0.6 +0.8 +1.0 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +x_cont1 = 1 +marg_post_x_fac3md = B +marg_post_x_cont1__xXx__x_fac3md[["1SD, C"]] +Density + + + + + + + + +0.4 +0.6 +0.8 +1.0 +1.2 + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-t-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-t-p.svg new file mode 100644 index 00000000..9d8188f4 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-t-p.svg @@ -0,0 +1,268 @@ + + + + + + + + + + + + + + + + + + + +marginal prior x_fac2t = A +attr(marg_post_x_fac2t[["A"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marginal prior x_fac2t = B +attr(marg_post_x_fac2t[["B"]], "prior_samples") +Density + + + + + + + + +-4 +-2 +0 +2 +4 + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-t.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-t.svg new file mode 100644 index 00000000..ab0a9f5d --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-fac-t.svg @@ -0,0 +1,153 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = A +marg_post_x_fac2t[["A"]] +Density + + + + + + + + + + +0.45 +0.50 +0.55 +0.60 +0.65 +0.70 +0.75 + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = B +marg_post_x_fac2t[["B"]] +Density + + + + + + + + + + +0.45 +0.50 +0.55 +0.60 +0.65 +0.70 +0.75 + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-int-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-int-p.svg new file mode 100644 index 00000000..e0790130 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-int-p.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + +marginal prior intercept +attr(marg_post_int[["intercept"]], "prior_samples") +Density + + + + + + +-4 +-2 +0 +2 +4 + + + + + +0.0 +0.1 +0.2 +0.3 + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-int.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-int.svg new file mode 100644 index 00000000..3861ed06 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-form-int.svg @@ -0,0 +1,77 @@ + + + + + + + + + + + + +marginal posterior intercept +marg_post_int[["intercept"]] +Density + + + + + + + + +0.45 +0.50 +0.55 +0.60 +0.65 +0.70 +0.75 + + + + + + + +0 +2 +4 +6 +8 +10 + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-con-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-con-p.svg new file mode 100644 index 00000000..fb5f81ba --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-con-p.svg @@ -0,0 +1,88 @@ + + + + + + + + + + + + +marginal prior sigma +attr(marg_post_sigma, "prior_samples") +Density + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-con.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-con.svg new file mode 100644 index 00000000..f9e929b0 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-con.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + +marginal posterior sigma +marg_post_sigma +Density + + + + + +0.45 +0.50 +0.55 +0.60 + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 +14 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-fac-p.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-fac-p.svg new file mode 100644 index 00000000..ae612df1 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-fac-p.svg @@ -0,0 +1,134 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = A +attr(marg_post_simple_x_fac2t[["A"]], "prior_samples") +Density + + + + + + + + + +-1.0 +-0.8 +-0.6 +-0.4 +-0.2 +0.0 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = B +attr(marg_post_simple_x_fac2t[["B"]], "prior_samples") +Density + + + + + + + + + + +-3 +-2 +-1 +0 +1 +2 +3 + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 +1.2 + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-fac.svg b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-fac.svg new file mode 100644 index 00000000..f4625233 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/marginal-ss-simple-fac.svg @@ -0,0 +1,144 @@ + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = A +marg_post_simple_x_fac2t[["A"]] +Density + + + + + + + + + +-1.0 +-0.8 +-0.6 +-0.4 +-0.2 +0.0 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + + + + + + + + + + + + + + +marg_post_x_fac2t = B +marg_post_simple_x_fac2t[["B"]] +Density + + + + + + + + + + +-0.3 +-0.2 +-0.1 +0.0 +0.1 +0.2 +0.3 + + + + + + +0 +10 +20 +30 +40 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-int.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-int.svg index 22eae3cd..3df96ac0 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-int.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-int.svg @@ -47,8 +47,8 @@ - - + + 0 @@ -74,10 +74,10 @@ 0.5 1.0 Density - - - - -intercept + + + + +intercept diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-cont1.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-cont1.svg index 4809c6df..2575419b 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-cont1.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-cont1.svg @@ -31,17 +31,17 @@ 0.6 0.8 1.0 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 Density @@ -50,18 +50,18 @@ - - - + + + -1SD 0SD 1SD - - - + + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-1.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-1.svg index a8eda1b9..3072d93c 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-1.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-1.svg @@ -31,17 +31,17 @@ 0.7 0.8 0.9 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 Density @@ -50,8 +50,8 @@ - - + + A diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-2.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-2.svg index 5fe1fd13..6e669861 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-2.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-2.svg @@ -31,17 +31,17 @@ 0.7 0.8 0.9 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 fac2t Density @@ -51,8 +51,8 @@ - - + + A diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-3.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-3.svg index d745fa18..ad348585 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-3.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-3.svg @@ -33,17 +33,17 @@ 2 4 6 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 Density @@ -52,14 +52,14 @@ - - + + A B - - + + A diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-4.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-4.svg index 3d3a3407..d7568175 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-4.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-4.svg @@ -31,17 +31,17 @@ 0.6 0.8 1.0 - + - - - - + + + + 0 -2 -4 -6 -8 +2 +4 +6 +8 Density @@ -50,14 +50,14 @@ - - + + A B - - + + A diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-5.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-5.svg index 50898eea..63b13942 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-5.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac2t-5.svg @@ -31,17 +31,17 @@ 3 4 5 - + - - - - + + + + 0 -1 -2 -3 -4 +1 +2 +3 +4 Density @@ -50,14 +50,14 @@ - - + + A B - - + + A diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac3md.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac3md.svg index a20731ab..141cc8fa 100644 --- a/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac3md.svg +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-mu-x-fac3md.svg @@ -29,23 +29,23 @@ 0.0 0.5 1.0 - + - - - - - - - + + + + + + + 0 -1 -2 -3 -4 -5 -6 -7 +1 +2 +3 +4 +5 +6 +7 Density @@ -54,18 +54,18 @@ - - - + + + A B C - - - + + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-int.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-int.svg new file mode 100644 index 00000000..e45e9d32 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-int.svg @@ -0,0 +1,87 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 +Density + + + + +intercept + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-cont1.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-cont1.svg new file mode 100644 index 00000000..ad3f420a --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-cont1.svg @@ -0,0 +1,74 @@ + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +2 +4 +6 +8 +10 +Density + + + + + + + + + + + + + +-1SD +0SD +1SD + + + + + + +-1SD +0SD +1SD + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-1.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-1.svg new file mode 100644 index 00000000..3ff3d572 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-1.svg @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + +0.5 +0.6 +0.7 +0.8 + + + + + + + +0 +2 +4 +6 +8 +10 +Density + + + + + + + + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-2.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-2.svg new file mode 100644 index 00000000..e2e29a7c --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-2.svg @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + + + + +0.5 +0.6 +0.7 +0.8 + + + + + + + +0 +2 +4 +6 +8 +10 +fac2t +Density + + + + + + + + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-3.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-3.svg new file mode 100644 index 00000000..07858b5a --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-3.svg @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + +-4 +-2 +0 +2 +4 +6 + + + + + + + +0 +2 +4 +6 +8 +10 +Density + + + + + + + + + + + +A +B + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-4.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-4.svg new file mode 100644 index 00000000..217731b7 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-4.svg @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +2 +4 +6 +8 +10 +Density + + + + + + + + + + + +A +B + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-5.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-5.svg new file mode 100644 index 00000000..8c220c7e --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac2t-5.svg @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + +0 +1 +2 +3 +4 +5 +Density + + + + + + + + + + + +A +B + + + + +A +B + + diff --git a/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac3md.svg b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac3md.svg new file mode 100644 index 00000000..1b3f0fc0 --- /dev/null +++ b/tests/testthat/_snaps/marginal-distributions/plot-marginal-ss-mu-x-fac3md.svg @@ -0,0 +1,74 @@ + + + + + + + + + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 +Density + + + + + + + + + + + + + +A +B +C + + + + + + +A +B +C + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-1.svg index 624a949a..06acb071 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-1.svg @@ -55,8 +55,8 @@ - - + + 0.0 @@ -90,12 +90,12 @@ 0.8 1.0 Density - - - - - -A -B + + + + + +A +B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-2.svg index e6546dca..c99d1850 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-i-2.svg @@ -53,8 +53,8 @@ - - + + 0.0 @@ -71,12 +71,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -94,13 +94,13 @@ 0.5 1.0 Density -Probability - - - - - -A -B +Probability + + + + + +A +B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-1.svg index 48fb75ec..fe36c9c4 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-1.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,11 +71,11 @@ - - - - - + + + + + 0 0.02 0.04 @@ -92,16 +92,16 @@ 0.5 1.0 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-2.svg index c24c8bf0..a3a6e85d 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-2.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,11 +71,11 @@ - - - - - + + + + + 0 0.02 0.04 @@ -92,16 +92,16 @@ 0.5 1.0 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-3.svg index 3d2da7f3..87d76fd4 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-3.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,11 +71,11 @@ - - - - - + + + + + 0 0.02 0.04 @@ -92,16 +92,16 @@ 0.5 1.0 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-4.svg index e15aea10..9ac9aecb 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-4.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,11 +71,11 @@ - - - - - + + + + + 0 0.02 0.04 @@ -92,6 +92,6 @@ 0.5 1.0 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-5.svg index 0a1d3e2a..ce59b858 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-md-5.svg @@ -59,9 +59,9 @@ - - - + + + 0.0 @@ -78,12 +78,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -105,16 +105,16 @@ 1.0 1.5 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-1.svg index 7d267242..1b3803e5 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-1.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,14 +71,14 @@ - - - - - - - - + + + + + + + + 0 0.01 0.02 @@ -98,16 +98,16 @@ 0.5 1.0 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-2.svg index 6e363bc6..e135309c 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-2.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,14 +71,14 @@ - - - - - - - - + + + + + + + + 0 0.01 0.02 @@ -98,16 +98,16 @@ 0.5 1.0 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-3.svg index e26a962a..b364e706 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-3.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,14 +71,14 @@ - - - - - - - - + + + + + + + + 0 0.01 0.02 @@ -98,16 +98,16 @@ 0.5 1.0 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-4.svg index fa852735..52d764c6 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-4.svg @@ -52,9 +52,9 @@ - - - + + + 0.0 @@ -71,14 +71,14 @@ - - - - - - - - + + + + + + + + 0 0.01 0.02 @@ -98,6 +98,6 @@ 0.5 1.0 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-5.svg index 1df08dd7..dcfcd6c6 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-o-5.svg @@ -59,9 +59,9 @@ - - - + + + 0.0 @@ -78,12 +78,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -105,16 +105,16 @@ 1.0 1.5 Density -Probability - - - - - - - - A - B - C +Probability + + + + + + + + A + B + C diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-1.svg index f33851af..572d24bd 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-1.svg @@ -58,7 +58,7 @@ - + 0.0 @@ -73,11 +73,11 @@ - - - - - + + + + + 0 0.05 0.1 @@ -102,10 +102,10 @@ 1.0 1.2 Density -Probability - - - -B +Probability + + + +B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-2.svg index 9207f73f..2715509f 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-2.svg @@ -58,7 +58,7 @@ - + 0.0 @@ -73,11 +73,11 @@ - - - - - + + + + + 0 0.05 0.1 @@ -102,10 +102,10 @@ 1.0 1.2 Density -Probability - - - -B +Probability + + + +B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-3.svg index 9e3737ef..2caf250d 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-3.svg @@ -58,7 +58,7 @@ - + 0.0 @@ -73,11 +73,11 @@ - - - - - + + + + + 0 0.05 0.1 @@ -102,10 +102,10 @@ 1.0 1.2 Density -Probability - - - -B +Probability + + + +B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-4.svg index 01a10ffa..81d517b2 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-4.svg @@ -58,7 +58,7 @@ - + 0.0 @@ -73,11 +73,11 @@ - - - - - + + + + + 0 0.05 0.1 @@ -102,6 +102,6 @@ 1.0 1.2 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-5.svg index 4912e60d..5f145850 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-ggplot-posterior-t-5.svg @@ -57,7 +57,7 @@ - + 0.0 @@ -72,12 +72,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -99,10 +99,10 @@ 1.0 1.5 Density -Probability - - - -B +Probability + + + +B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-1.svg index 0457dcab..0cf048fd 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-1.svg @@ -31,19 +31,19 @@ 0.4 0.6 0.8 - + - - - - - + + + + + 0.0 -0.5 -1.0 -1.5 -2.0 -2.5 +0.5 +1.0 +1.5 +2.0 +2.5 Density @@ -52,8 +52,8 @@ - - + + A diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-2.svg index 77a4c6ec..0b9d8c8d 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-2.svg @@ -31,19 +31,19 @@ 0.4 0.6 0.8 - + - - - - - + + + + + 0.0 -0.5 -1.0 -1.5 -2.0 -2.5 +0.5 +1.0 +1.5 +2.0 +2.5 Density @@ -52,8 +52,8 @@ - - + + A diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-3.svg index 620eac74..9b43ffaf 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-i-3.svg @@ -65,8 +65,8 @@ - - + + A diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-1.svg index d817afb6..505c071e 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-1.svg @@ -62,9 +62,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-2.svg index ec634a59..8d8f0572 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-2.svg @@ -62,9 +62,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-3.svg index a7983399..5433f428 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-3.svg @@ -62,9 +62,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-4.svg index ffe343f9..af108230 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-4.svg @@ -62,8 +62,8 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-5.svg index f32ba970..50a955dd 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-md-5.svg @@ -71,9 +71,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-1.svg index 5c397d41..24f66831 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-1.svg @@ -68,9 +68,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-2.svg index 95bba711..c172bb20 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-2.svg @@ -68,9 +68,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-3.svg index 72dbbc5c..cb53e118 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-3.svg @@ -68,9 +68,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-4.svg index b4a45edb..bc233855 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-4.svg @@ -68,8 +68,8 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-5.svg index bf4052ad..9cc62e7a 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-o-5.svg @@ -71,9 +71,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-1.svg index f045384a..cdae3614 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-1.svg @@ -65,7 +65,7 @@ - + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-2.svg index b51f5abd..5752b611 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-2.svg @@ -48,7 +48,7 @@ - + @@ -66,13 +66,13 @@ - - - - - - - + + + + + + + 0 0.1 0.2 @@ -93,6 +93,6 @@ 1.0 1.5 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-3.svg index 8f0a128c..3981682f 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-3.svg @@ -27,17 +27,17 @@ 1 2 3 - + - - - - + + + + 0.0 -0.2 -0.4 -0.6 -0.8 +0.2 +0.4 +0.6 +0.8 Density @@ -46,7 +46,7 @@ - - + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-4.svg index 3df1a7a2..8f4aaaae 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-4.svg @@ -47,7 +47,7 @@ - + 0.0 diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-5.svg index 97cfc838..5e5e872d 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-5.svg @@ -29,21 +29,21 @@ 20 30 40 - + - - - - - - + + + + + + 0.0 -0.1 -0.2 -0.3 -0.4 -0.5 -0.6 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 Density @@ -52,7 +52,7 @@ - - + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-6.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-6.svg index 40e1eb2b..676e924a 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-6.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-6.svg @@ -67,7 +67,7 @@ - + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-8.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-8.svg index 1b063ce0..8e8d72eb 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-8.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-simple-8.svg @@ -49,6 +49,6 @@ - + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-1.svg index 425fb9d1..f453553e 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-1.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-1.svg @@ -68,7 +68,7 @@ - + B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-2.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-2.svg index 02b709f8..734148b5 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-2.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-2.svg @@ -68,7 +68,7 @@ - + B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-3.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-3.svg index 57c58ec5..5cbf0032 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-3.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-3.svg @@ -68,7 +68,7 @@ - + B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-4.svg index a3580ffb..604a442b 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-4.svg @@ -68,6 +68,6 @@ - + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-5.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-5.svg index af9c88ec..660b6969 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-5.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-posterior-t-5.svg @@ -69,7 +69,7 @@ - + B diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-meandif-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-meandif-4.svg index 1a5b8a5b..b2b17b25 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-meandif-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-meandif-4.svg @@ -65,12 +65,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -92,6 +92,6 @@ 2 3 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-orthonormal-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-orthonormal-4.svg index 912f4955..0c271ff2 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-orthonormal-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-orthonormal-4.svg @@ -69,12 +69,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -96,6 +96,6 @@ 2 3 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-treatment-4.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-treatment-4.svg index 4e17d805..5206168c 100644 --- a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-treatment-4.svg +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-prior-treatment-4.svg @@ -71,12 +71,12 @@ - - - - - - + + + + + + 0 0.1 0.2 @@ -96,6 +96,6 @@ 0.8 1.0 Density -Probability +Probability diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-bias-pet.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-bias-pet.svg new file mode 100644 index 00000000..29c2cc7c --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-bias-pet.svg @@ -0,0 +1,78 @@ + + + + + + + + + + + + +Density + + + + + + +0 +1 +2 +3 +4 + + + + + + + + + +0 +0.02 +0.04 +0.06 +0.08 +0.1 +0.12 +0.14 + + + + + + + +0 +0.2 +0.4 +0.6 +0.8 +1 +Probability + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-intercept-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-intercept-con.svg new file mode 100644 index 00000000..6be81d4f --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-intercept-con.svg @@ -0,0 +1,54 @@ + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +0 +2 +4 +6 +8 +Density + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-intercept.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-intercept.svg new file mode 100644 index 00000000..c53810f7 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-intercept.svg @@ -0,0 +1,74 @@ + + + + + + + + + + + + +Density + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 +0.5 +Probability + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-omega-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-omega-con.svg new file mode 100644 index 00000000..a03d4bfa --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-omega-con.svg @@ -0,0 +1,730 @@ + + + + + + + + + + + + + + + + + + + +omega[0,0.025] +omega[0,0.025] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + +0 +5000 +10000 +15000 + + + + + + + + + + + + + + + + + + + + + + +omega[0.025,0.05] +omega[0.025,0.05] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +2000 +4000 +6000 +8000 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[0.05,0.975] +omega[0.05,0.975] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +2000 +4000 +6000 +8000 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[0,0.025] +omega[0,0.025] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + +0 +2000 +4000 +6000 +8000 + + + + + + + + + + + + + + + + + +omega[0.025,0.05] +omega[0.025,0.05] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +500 +1000 +1500 +2000 +2500 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[0.05,0.975] +omega[0.05,0.975] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +500 +1000 +1500 +2000 +2500 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[0,0.025] +omega[0,0.025] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + +0 +1000 +2000 +3000 +4000 +5000 + + + + + + + + + + + + + + + + + +omega[0.025,0.05] +omega[0.025,0.05] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + +0 +50 +100 +150 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +omega[0.05,0.975] +omega[0.05,0.975] +Frequency + + + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + +0 +50 +100 +150 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-pet-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-pet-con.svg new file mode 100644 index 00000000..8c931e56 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-pet-con.svg @@ -0,0 +1,260 @@ + + + + + + + + + + + + + + + + + + + +PET +PET +Frequency + + + + + + + +0 +1 +2 +3 + + + + + + + + + +0 +2000 +6000 +10000 +14000 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +PET +PET +Frequency + + + + + + + +0 +1 +2 +3 + + + + + + + +0 +1000 +3000 +5000 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +PET +PET +Frequency + + + + + + + +0 +1 +2 +3 + + + + + + +0 +50 +100 +150 +200 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-sigma.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-sigma.svg new file mode 100644 index 00000000..d9398048 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-sigma.svg @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + + + + +0 +2 +4 +6 +8 +10 +12 + + + + + + + +0 +2 +4 +6 +8 +10 +Density + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-weightfunction-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-weightfunction-con.svg new file mode 100644 index 00000000..a15f000a --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-weightfunction-con.svg @@ -0,0 +1,59 @@ + + + + + + + + + + + + +Selection Models +p +-value +Probability + + + + + + +0 +0.05 +0.975 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-weightfunction.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-weightfunction.svg new file mode 100644 index 00000000..e980dd60 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-weightfunction.svg @@ -0,0 +1,59 @@ + + + + + + + + + + + + +Selection Models +p +-value +Probability + + + + + + +0 +0.05 +0.975 + + + + + + + +0.0 +0.2 +0.4 +0.6 +0.8 +1.0 + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-cont1-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-cont1-con.svg new file mode 100644 index 00000000..0e6a4761 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-cont1-con.svg @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + +0 +1 +2 +3 +4 +5 +6 +Density + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-cont1.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-cont1.svg new file mode 100644 index 00000000..bb922837 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-cont1.svg @@ -0,0 +1,76 @@ + + + + + + + + + + + + +Density + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + +0 +1 +2 +3 +4 +5 +6 +7 + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 +0.5 +Probability + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac2t-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac2t-con.svg new file mode 100644 index 00000000..ae80863c --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac2t-con.svg @@ -0,0 +1,55 @@ + + + + + + + + + + + + + + + + +-1 +0 +1 + + + + + + +0 +1 +2 +3 +4 +Density + + + + + + + + + + + + + A + B + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac2t.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac2t.svg new file mode 100644 index 00000000..d2a24689 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac2t.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + +Density + + + + +-1 +0 +1 + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 +0.5 + + + + + + + +0 +0.2 +0.4 +0.6 +0.8 +1 +Probability + + + + + + + + + + + + + + + + + A + B + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac3t-con.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac3t-con.svg new file mode 100644 index 00000000..5e18c641 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac3t-con.svg @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +0.0 +0.5 +1.0 +1.5 +2.0 +Density + + + + + + + + + + + + + + + A + B + C + + diff --git a/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac3t.svg b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac3t.svg new file mode 100644 index 00000000..57144f25 --- /dev/null +++ b/tests/testthat/_snaps/model-averaging-plots/model-averaging-plot-ss-posterior-x-fac3t.svg @@ -0,0 +1,80 @@ + + + + + + + + + + + + +Density + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +0 +0.5 +1 +1.5 +2 + + + + + + + +0 +0.1 +0.2 +0.3 +0.4 +0.5 +Probability + + + + + + + + + + + + + + + + + + + A + B + C + + diff --git a/tests/testthat/_snaps/priors-density/prior-density-1-5.svg b/tests/testthat/_snaps/priors-density/prior-density-1-5.svg index 4cf4c44d..edc6fb03 100644 --- a/tests/testthat/_snaps/priors-density/prior-density-1-5.svg +++ b/tests/testthat/_snaps/priors-density/prior-density-1-5.svg @@ -25,7 +25,7 @@ - + @@ -39,17 +39,17 @@ 0 1 2 - + - - - - + + + + 0.0 -0.1 -0.2 -0.3 -0.4 +0.1 +0.2 +0.3 +0.4 density("Normal(0, 1)") N = 1000 Bandwidth = diff --git a/tests/testthat/_snaps/priors-density/prior-density-2-5.svg b/tests/testthat/_snaps/priors-density/prior-density-2-5.svg index 4a2bff43..b31ea3cd 100644 --- a/tests/testthat/_snaps/priors-density/prior-density-2-5.svg +++ b/tests/testthat/_snaps/priors-density/prior-density-2-5.svg @@ -25,7 +25,7 @@ - + @@ -41,15 +41,15 @@ 1.5 2.0 2.5 - + - - - + + + 0.0 -0.2 -0.4 -0.6 +0.2 +0.4 +0.6 density("Normal(0, 1)[0, Inf]") N = 1000 Bandwidth = diff --git a/tests/testthat/_snaps/priors-plot/priors-plot-3-5.svg b/tests/testthat/_snaps/priors-plot/priors-plot-3-5.svg index 0f25bebf..55c5392d 100644 --- a/tests/testthat/_snaps/priors-plot/priors-plot-3-5.svg +++ b/tests/testthat/_snaps/priors-plot/priors-plot-3-5.svg @@ -31,19 +31,19 @@ 6 8 10 - + - - - - - + + + + + 0.0 -0.1 -0.2 -0.3 -0.4 -0.5 +0.1 +0.2 +0.3 +0.4 +0.5 Cauchy (0, 1) @@ -60,6 +60,6 @@ - + diff --git a/tests/testthat/_snaps/priors-print/priors-print-4.svg b/tests/testthat/_snaps/priors-print/priors-print-4.svg index 55476960..01a17dc7 100644 --- a/tests/testthat/_snaps/priors-print/priors-print-4.svg +++ b/tests/testthat/_snaps/priors-print/priors-print-4.svg @@ -32,5 +32,100 @@ Beta (3, 2) +( +1 +/ +3 +) + +* + +Normal +(0, 1) + ++ + +( +1 +/ +3 +) + +* + +Normal +(-3, 1) + ++ + +( +1 +/ +3 +) + +* + +Gamma +(5, 10) +( +1 +/ +7 +) + +* + +Normal +(0, 1) + ++ + +( +5 +/ +7 +) + +* + +Normal +(-3, 1) + ++ + +( +1 +/ +7 +) + +* + +Gamma +(5, 10) +( +1 +/ +6 +) + +* + +Normal +(0, 1) + ++ + +( +5 +/ +6 +) + +* + +Normal +(-3, 1) diff --git a/tests/testthat/_snaps/priors/prior-mixture-1.svg b/tests/testthat/_snaps/priors/prior-mixture-1.svg new file mode 100644 index 00000000..72edd4d8 --- /dev/null +++ b/tests/testthat/_snaps/priors/prior-mixture-1.svg @@ -0,0 +1,157 @@ + + + + + + + + + + + + +( +1 +/ +3 +) + +* + +Normal +(0, 1) + ++ + +( +1 +/ +3 +) + +* + +Normal +(-3, 1) + ++ + +( +1 +/ +3 +) + +* + +Gamma +(5, 10) +samples +Density + + + + + + + +-6 +-4 +-2 +0 +2 +4 + + + + + + + + + +0.0 +0.1 +0.2 +0.3 +0.4 +0.5 +0.6 +0.7 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/priors/prior-mixture-2.svg b/tests/testthat/_snaps/priors/prior-mixture-2.svg new file mode 100644 index 00000000..32d87092 --- /dev/null +++ b/tests/testthat/_snaps/priors/prior-mixture-2.svg @@ -0,0 +1,155 @@ + + + + + + + + + + + + +( +1 +/ +7 +) + +* + +Normal +(0, 1) + ++ + +( +5 +/ +7 +) + +* + +Normal +(-3, 1) + ++ + +( +1 +/ +7 +) + +* + +Gamma +(5, 10) +samples +Density + + + + + + + + +-8 +-6 +-4 +-2 +0 +2 +4 + + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/priors/prior-mixture-3.svg b/tests/testthat/_snaps/priors/prior-mixture-3.svg new file mode 100644 index 00000000..6d0522a1 --- /dev/null +++ b/tests/testthat/_snaps/priors/prior-mixture-3.svg @@ -0,0 +1,145 @@ + + + + + + + + + + + + +( +1 +/ +6 +) + +* + +Normal +(0, 1) + ++ + +( +5 +/ +6 +) + +* + +Normal +(-3, 1) +samples +Density + + + + + + + + +-8 +-6 +-4 +-2 +0 +2 +4 + + + + + + + + +0.00 +0.05 +0.10 +0.15 +0.20 +0.25 +0.30 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/priors/prior-mixture-4.svg b/tests/testthat/_snaps/priors/prior-mixture-4.svg new file mode 100644 index 00000000..baa9cd23 --- /dev/null +++ b/tests/testthat/_snaps/priors/prior-mixture-4.svg @@ -0,0 +1,132 @@ + + + + + + + + + + + + +( +1 +/ +5 +) + +* + +orthonormal contrast: +mSpike +(0) + ++ + +( +3 +/ +5 +) + +* + +orthonormal contrast: +mNormal +(0, 10) + ++ + +( +1 +/ +5 +) + +* + +orthonormal contrast: +mNormal +(0, 1) +rng(p4, 10000, transform_factor_samples = FALSE) +Density + + + + + + +-40 +-20 +0 +20 +40 + + + + + +0.00 +0.05 +0.10 +0.15 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/priors/prior-mixture-5.svg b/tests/testthat/_snaps/priors/prior-mixture-5.svg new file mode 100644 index 00000000..af5b50c8 --- /dev/null +++ b/tests/testthat/_snaps/priors/prior-mixture-5.svg @@ -0,0 +1,125 @@ + + + + + + + + + + + + +( +1 +/ +5 +) + +* + +orthonormal contrast: +mSpike +(0) + ++ + +( +3 +/ +5 +) + +* + +orthonormal contrast: +mNormal +(0, 10) + ++ + +( +1 +/ +5 +) + +* + +orthonormal contrast: +mNormal +(0, 1) +rng(p4, 10000, transform_factor_samples = TRUE) +Density + + + + + +-20 +0 +20 +40 + + + + + +0.00 +0.05 +0.10 +0.15 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/priors/prior-spike-and-slab-1.svg b/tests/testthat/_snaps/priors/prior-spike-and-slab-1.svg index a6152a5a..85310e92 100644 --- a/tests/testthat/_snaps/priors/prior-spike-and-slab-1.svg +++ b/tests/testthat/_snaps/priors/prior-spike-and-slab-1.svg @@ -27,17 +27,15 @@ (2, 1) samples[samples != 0] Density - + - - - - + + + 0 -2 -4 -6 -8 +2 +4 +6 @@ -58,46 +56,44 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-5.svg b/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-5.svg index c5ca87e1..d419df65 100644 --- a/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-5.svg +++ b/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-5.svg @@ -130,7 +130,7 @@ - + @@ -247,6 +247,6 @@ - + diff --git a/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-6.svg b/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-6.svg index 7fedc4b5..69e0aa55 100644 --- a/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-6.svg +++ b/tests/testthat/_snaps/priors/prior-weigthfunction-one-sided-6.svg @@ -128,7 +128,7 @@ - + @@ -241,7 +241,7 @@ - + @@ -354,6 +354,6 @@ - + diff --git a/tests/testthat/test-JAGS-fit.R b/tests/testthat/test-JAGS-fit.R index 0483974e..f60dde9c 100644 --- a/tests/testthat/test-JAGS-fit.R +++ b/tests/testthat/test-JAGS-fit.R @@ -364,6 +364,103 @@ test_that("JAGS model functions work (spike and slab)", { } }) +test_that("JAGS model functions work (mixture)", { + + skip_if_not_installed("rjags") + priors <- list( + "mu" = prior_mixture( + list( + prior("normal", list(0, 1), prior_weights = 1), + prior("normal", list(-3, 1), prior_weights = 5), + prior("gamma", list(5, 10), prior_weights = 1) + ), + is_null = c(T, F, T) + ), + "beta" = prior_mixture( + list( + prior("normal", list(0, 1), prior_weights = 1), + prior("normal", list(-3, 1), prior_weights = 5) + ), + components = c("b", "a") + ), + "gamma" = prior_mixture( + list( + prior("spike", list(2)), + prior("normal", list(-3, 1)) + ) + ), + "bias" = prior_mixture(list( + prior_weightfunction(distribution = "two.sided", parameters = list(alpha = c(1, 1), steps = c(0.05)), prior_weights = 1/12), + prior_weightfunction(distribution = "two.sided", parameters = list(alpha = c(1, 1, 1), steps = c(0.05, 0.10)), prior_weights = 1/12), + prior_weightfunction(distribution = "one.sided", parameters = list(alpha = c(1, 1), steps = c(0.05)), prior_weights = 1/12), + prior_weightfunction(distribution = "one.sided", parameters = list(alpha = c(1, 1, 1), steps = c(0.025, 0.05)), prior_weights = 1/12), + prior_weightfunction(distribution = "one.sided", parameters = list(alpha = c(1, 1, 1), steps = c(0.05, 0.5)), prior_weights = 1/12), + prior_weightfunction(distribution = "one.sided", parameters = list(alpha = c(1, 1, 1, 1), steps = c(0.025, 0.05, 0.5)), prior_weights = 1/12), + prior_PET(distribution = "Cauchy", parameters = list(0,1), truncation = list(0, Inf), prior_weights = 1/4), + prior_PEESE(distribution = "Cauchy", parameters = list(0,5), truncation = list(0, Inf), prior_weights = 1/4) + )) + ) + + + + for(i in 1:length(priors)){ + model_syntax <- "model{}" + model_syntax <- JAGS_add_priors(model_syntax, priors[i]) + monitor <- JAGS_to_monitor(priors[i]) + inits <- JAGS_get_inits(priors[i], chains = 2, seed = 1) + + if(i == 4){ + if("RoBMA" %in% rownames(installed.packages())){ + require("RoBMA") + }else{ + next + } + } + + set.seed(1) + model <- rjags::jags.model(file = textConnection(model_syntax), inits = inits, n.chains = 2, quiet = TRUE) + samples <- rjags::coda.samples(model = model, variable.names = monitor, n.iter = 5000, quiet = TRUE, progress.bar = "none") + samples <- do.call(rbind, samples) + + + if(i != 4){ + vdiffr::expect_doppelganger(paste0("JAGS-model-prior_mixture-",i), function(){ + temp_samples <- samples[,names(priors)[i]] + hist(temp_samples, breaks = 100, freq = FALSE, main = print(priors[[i]], plot = TRUE)) + lines(density(rng(priors[[i]], 1000000))) + }) + }else{ + vdiffr::expect_doppelganger(paste0("JAGS-model-prior_mixture-",i), function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + par(mfrow = c(3, 3)) + + samples_PET <- samples[,"PET"] + samples_PEESE <- samples[,"PEESE"] + samples_omega <- samples[,paste0("omega[",1:6,"]")] + samples_bias <- samples[,"bias_indicator"] + + barplot(table(samples_bias)/length(samples_bias), main = "Bias componenets") + + hist(samples_PET[samples_PET != 0 & samples_PET < 10], breaks = 50, main = "PET", freq = FALSE) + lines(priors$bias[[7]], individual = TRUE) + + hist(samples_PEESE[samples_PEESE != 0 & samples_PEESE < 20], breaks = 50, main = "PEESE", freq = FALSE) + lines(priors$bias[[8]], individual = TRUE) + + hist(samples_omega[samples_bias == 2, 1], breaks = 50, main = "omega[2:1]", freq = FALSE) + hist(samples_omega[samples_bias == 2, 2], breaks = 50, main = "omega[2:2]", freq = FALSE) + hist(samples_omega[samples_bias == 2, 3], breaks = 50, main = "omega[2:3]", freq = FALSE) + hist(samples_omega[samples_bias == 2, 4], breaks = 50, main = "omega[2:4]", freq = FALSE) + hist(samples_omega[samples_bias == 2, 5], breaks = 50, main = "omega[2:5]", freq = FALSE) + hist(samples_omega[samples_bias == 2, 6], breaks = 50, main = "omega[2:6]", freq = FALSE) + + }) + } + } +}) + test_that("JAGS fit function works" , { set.seed(1) @@ -446,10 +543,10 @@ test_that("JAGS fit function works" , { convergence <- JAGS_check_convergence(fit4, prior_list = priors_list4, max_Rhat = 1.001, min_ESS = 500, max_error = 0.01, max_SD_error = 0.05) expect_true(!convergence) - expect_equal(attr(convergence, "errors")[1], "R-hat 1.007 is larger than the set target (1.001).") + expect_equal(attr(convergence, "errors")[1], "R-hat 1.053 is larger than the set target (1.001).") expect_equal(attr(convergence, "errors")[2], "ESS 149 is lower than the set target (500).") - expect_equal(attr(convergence, "errors")[3], "MCMC error 0.0698 is larger than the set target (0.01).") - expect_equal(attr(convergence, "errors")[4], "MCMC SD error 0.082 is larger than the set target (0.05).") + expect_equal(attr(convergence, "errors")[3], "MCMC error 0.07422 is larger than the set target (0.01).") + expect_equal(attr(convergence, "errors")[4], "MCMC SD error 0.087 is larger than the set target (0.05).") fit4b <- JAGS_fit(model_syntax4, data4, priors_list4, autofit = TRUE, autofit_control = list(max_error = 0.05, sample_extend = 100), chains = 2, adapt = 100, burnin = 50, sample = 100, seed = 4) @@ -703,6 +800,110 @@ test_that("JAGS fit function integration with formula and spike and slab works" }) +test_that("JAGS fit function integration with formula, spike and slab works, and mixture works" , { + + skip_on_os(c("mac", "linux", "solaris")) # multivariate sampling does not exactly match across OSes + skip_on_cran() + + set.seed(1) + + data_formula <- data.frame( + x_cont1 = rnorm(300), + x_fac2t = factor(rep(c("A", "B"), 150), levels = c("A", "B")), + x_fac3t = factor(rep(c("A", "B", "C"), 100), levels = c("A", "B", "C")) + ) + data <- list( + y = rnorm(300, -0.15 + 0.20 * data_formula$x_cont1 + ifelse(data_formula$x_fac3t == "A", 0.0, ifelse(data_formula$x_fac3t == "B", -0.2, 0.2)), ifelse(data_formula$x_fac2t == "A", 0.5, 1)), + N = 300 + ) + + # create model with mix of a formula and free parameters --- + formula_list1 <- list( + mu = ~ x_cont1 + x_fac3t + ) + formula_data_list1 <- list( + mu = data_formula + ) + formula_prior_list1 <- list( + mu = list( + "intercept" = prior_mixture( + list( + prior("spike", list(0), prior_weights = 2), + prior("normal", list(-1, 0.5), prior_weights = 1), + prior("normal", list( 1, 0.5), prior_weights = 1) + ), + is_null = c(T, F, F) + ), + "x_cont1" = prior_mixture( + list( + prior("spike", list(0), prior_weights = 1), + prior("normal", list(0, 1), prior_weights = 1) + ), + is_null = c(T, F) + ), + "x_fac3t" = prior_spike_and_slab(prior_factor("mnormal", list(0, 1), contrast = "orthonormal"), + prior_inclusion = prior("spike", list(0.5))) + ) + ) + attr(formula_prior_list1$mu$x_cont1, "multiply_by") <- "sigma" + prior_list1 <- list( + "sigma" = prior_mixture( + list( + prior("normal", list(0, 1), truncation = list(0, Inf)), + prior("lognormal", list(0, 1)) + ), + is_null = c(T, F) + ) + ) + model_syntax1 <- paste0( + "model{\n", + "for(i in 1:N){\n", + " y[i] ~ dnorm(mu[i], 1/pow(sigma, 2))\n", + "}\n", + "}" + ) + + fit1 <- JAGS_fit( + model_syntax = model_syntax1, data = data, prior_list = prior_list1, + formula_list = formula_list1, formula_data_list = formula_data_list1, formula_prior_list = formula_prior_list1) + + posterior1 <- suppressWarnings(coda::as.mcmc(fit1)) + + vdiffr::expect_doppelganger("JAGS-fit-formula-mixture-1", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfcol = oldpar[["mfcol"]])) + par(mfrow = c(3, 3)) + + barplot(table(posterior1[,"mu_intercept_indicator"]) / nrow(posterior1), main = "Intercept indicator") + barplot(table(posterior1[,"mu_x_cont1_indicator"]) / nrow(posterior1), main = "x_cont1 indicator") + barplot(table(posterior1[,"sigma_indicator"]) / nrow(posterior1), main = "sigma indicator") + + hist(posterior1[,"mu_intercept"], freq = FALSE, main = "mu_intercept") + hist(posterior1[,"mu_x_cont1"], freq = FALSE, main = "x_cont1") + hist(posterior1[,"sigma"], freq = FALSE, main = "sigma") + }) + + vdiffr::expect_doppelganger("JAGS-fit-formula-mixture-2", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfcol = oldpar[["mfcol"]])) + par(mfrow = c(2, 3)) + + temp_samples <- posterior1[,paste0("mu_x_fac3t[", 1:2, "]")] %*% t(contr.orthonormal(1:3)) + temp_samples_variable <- posterior1[,paste0("mu_x_fac3t_variable[", 1:2, "]")] %*% t(contr.orthonormal(1:3)) + + hist(temp_samples[,1], freq = FALSE, main = "x_fac3t[A]") + hist(temp_samples[,2], freq = FALSE, main = "x_fac3t[B]") + hist(temp_samples[,3], freq = FALSE, main = "x_fac3t[C]") + + hist(temp_samples_variable[,1], freq = FALSE, main = "x_fac3t_variable[A]") + hist(temp_samples_variable[,2], freq = FALSE, main = "x_fac3t_variable[B]") + hist(temp_samples_variable[,3], freq = FALSE, main = "x_fac3t_variable[C]") + }) + +}) + test_that("JAGS parallel fit function works" , { skip("requires parallel processing") diff --git a/tests/testthat/test-marginal-distributions.R b/tests/testthat/test-marginal-distributions.R index 22d52c0b..cac2232f 100644 --- a/tests/testthat/test-marginal-distributions.R +++ b/tests/testthat/test-marginal-distributions.R @@ -590,7 +590,7 @@ test_that("Marginal distribution prior and posterior functions work", { # simple factor BF.marg_post_x_fac2t <- suppressWarnings(Savage_Dickey_BF(marg_post_simple_x_fac2t)) - expect_equivalent(BF.marg_post_x_fac2t, list("A" = 1, "B" = 1.660247), tolerance = 1e-5) + expect_equivalent(BF.marg_post_x_fac2t, list("A" = 1, "B" = 1.660692), tolerance = 1e-3) expect_equal(attr(BF.marg_post_x_fac2t[["A"]], "warnings"), c("There is a considerable cluster of posterior samples at the exact null hypothesis values. The Savage-Dickey density ratio is likely to be invalid.", "There is a considerable cluster of prior samples at the exact null hypothesis values. The Savage-Dickey density ratio is likely to be invalid.")) @@ -600,10 +600,10 @@ test_that("Marginal distribution prior and posterior functions work", { expect_equivalent(BF.marg_post_x_fac3md, list("A" = Inf, "B" = Inf, "C" = Inf)) BF2.marg_post_x_fac3md <- Savage_Dickey_BF(marg_post_x_fac3md, null_hypothesis = 0.5) - expect_equivalent(BF2.marg_post_x_fac3md, list("A" = 3.950433, "B" = 0.1405758, "C" = 0.1661129), tolerance = 1e-5) + expect_equivalent(BF2.marg_post_x_fac3md, list("A" = 3.954431, "B" = 0.1405823, "C" = 0.1661251), tolerance = 1e-3) BF2.marg_post_x_fac3md <- Savage_Dickey_BF(marg_post_x_fac3md, null_hypothesis = 0.5, normal_approximation = TRUE) - expect_equal(BF2.marg_post_x_fac3md, list("A" = 0.6342651, "B" = 0.1015235, "C" = 0.1267758), tolerance = 1e-5) + expect_equal(BF2.marg_post_x_fac3md, list("A" = 0.6342651, "B" = 0.1015235, "C" = 0.1267758), tolerance = 1e-3) ### marginal_inference ---- out <- marginal_inference( @@ -699,10 +699,10 @@ test_that("Marginal distribution prior and posterior functions work", { "(mu) x_cont1:x_fac3md[-1SD, A] 0.556 0.556 0.344 0.734 Inf" , "(mu) x_cont1:x_fac3md[0SD, A] 0.770 0.772 0.618 0.893 Inf" , "(mu) x_cont1:x_fac3md[1SD, A] 0.984 0.985 0.791 1.140 Inf" , - "(mu) x_cont1:x_fac3md[-1SD, B] 0.372 0.372 0.159 0.556 10.812" , + "(mu) x_cont1:x_fac3md[-1SD, B] 0.372 0.372 0.159 0.556 10.816" , "(mu) x_cont1:x_fac3md[0SD, B] 0.518 0.518 0.365 0.646 Inf" , "(mu) x_cont1:x_fac3md[1SD, B] 0.665 0.664 0.464 0.830 Inf" , - "(mu) x_cont1:x_fac3md[-1SD, C] 0.373 0.373 0.171 0.541 69.936" , + "(mu) x_cont1:x_fac3md[-1SD, C] 0.373 0.373 0.171 0.541 69.939" , "(mu) x_cont1:x_fac3md[0SD, C] 0.550 0.551 0.405 0.674 Inf" , "(mu) x_cont1:x_fac3md[1SD, C] 0.727 0.727 0.524 0.904 Inf" , "\033[0;31mmu_intercept: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , @@ -817,3 +817,527 @@ test_that("Marginal distribution prior functions work", { }) }) + +test_that("Marginal distributions with spike and slab and mixture priors work", { + + skip_on_os(c("mac", "linux", "solaris")) # multivariate sampling does not exactly match across OSes + skip_on_cran() + + ### complex formula including scaling ---- + set.seed(1) + df_all <- data.frame( + x_cont1 = rnorm(180), + x_fac2t = factor(rep(c("A", "B"), 90), levels = c("A", "B")), + x_fac3md = factor(rep(c("A", "B", "C"), 60), levels = c("A", "B", "C")) + ) + df_all$y <- rnorm(180, 0.1, 0.5) + 0.5 + 0.20 * df_all$x_cont1 + + ifelse(df_all$x_fac3md == "A", 0.15, ifelse(df_all$x_fac3md == "B", -0.15, 0)) + + prior_pars <- list( + "intercept" = prior("normal", list(0, 1)), + "x_cont1" = prior_mixture(list( + prior("spike", list(0)), + prior("normal", list(0, 1)) + ), is_null = c(T, F)), + "x_fac2t" = prior_spike_and_slab(prior_factor("normal", contrast = "treatment", list(0, 1.00))), + "x_fac3md" = prior_spike_and_slab(prior_factor("mnormal", contrast = "meandif", list(0, 0.25))), + "x_cont1:x_fac3md" = prior_spike_and_slab(prior_factor("mnormal", contrast = "meandif", list(0, 0.25))) + ) + prior_list <- list( + "sigma" = prior("cauchy", list(0, 1), list(0, 5)) + ) + attr(prior_pars$x_cont1, "multiply_by") <- "sigma" + model_syntax <- paste0( + "model{", + "for(i in 1:N){\n", + " y[i] ~ dnorm(mu[i], 1/pow(sigma, 2))\n", + "}\n", + "}" + ) + + model_formula <- list(mu = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md) + + fit <- JAGS_fit( + model_syntax = model_syntax, data = list(y = df_all$y, N = nrow(df_all)), + prior_list = prior_list, + formula_list = model_formula, + formula_prior_list = list(mu = prior_pars), + formula_data_list = list(mu = df_all)) + + mixed_posteriors <- as_mixed_posteriors( + model = fit, + parameters = c("sigma", "mu_intercept", "mu_x_cont1", "mu_x_fac2t", "mu_x_fac3md", "mu_x_cont1__xXx__x_fac3md") + ) + + ### simple: continuous parameter ---- + marg_post_sigma <- marginal_posterior( + samples = mixed_posteriors, + parameter = "sigma", + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-simple-con", function(){ + hist(marg_post_sigma, freq = FALSE, main = "marginal posterior sigma") + }) + + vdiffr::expect_doppelganger("marginal-ss-simple-con-p", function(){ + hist(attr(marg_post_sigma, "prior_samples"), freq = FALSE, main = "marginal prior sigma", breaks = 20) + lines(density(prior_list$sigma)) + }) + + + ### simple: factor ---- + marg_post_simple_x_fac2t <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_fac2t", + prior_samples = TRUE, + use_formula = FALSE) + + vdiffr::expect_doppelganger("marginal-ss-simple-fac", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 2)) + hist(marg_post_simple_x_fac2t[["A"]], freq = FALSE, main = "marg_post_x_fac2t = A") + + hist(marg_post_simple_x_fac2t[["B"]], freq = FALSE, main = "marg_post_x_fac2t = B", breaks = 20) + }) + + vdiffr::expect_doppelganger("marginal-ss-simple-fac-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 2)) + hist(attr(marg_post_simple_x_fac2t[["A"]], "prior_samples"), freq = FALSE, main = "marg_post_x_fac2t = A", breaks = 20) + + hist(attr(marg_post_simple_x_fac2t[["B"]], "prior_samples"), freq = FALSE, main = "marg_post_x_fac2t = B", breaks = 20) + curve(dnorm(x, 0, 1)/2, add = T) + + }) + + + ### formula: intercept ---- + marg_post_int <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_intercept", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-form-int", function(){ + hist(marg_post_int[["intercept"]], freq = FALSE, main = "marginal posterior intercept") + }) + + vdiffr::expect_doppelganger("marginal-ss-form-int-p", function(){ + hist(attr(marg_post_int[["intercept"]], "prior_samples"), freq = FALSE, main = "marginal prior intercept") + lines(prior_pars$intercept) + }) + + + ### formula: continuous parameter (-+1SD) ---- + marg_post_x_cont1 <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_cont1", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-form-con", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(marg_post_x_cont1[["-1SD"]], freq = FALSE, main = "marginal posterior x_cont1\n(-1)") + hist(marg_post_x_cont1[["0SD"]], freq = FALSE, main = "marginal posterior x_cont1\n(0)") + hist(marg_post_x_cont1[["1SD"]], freq = FALSE, main = "marginal posterior x_cont1\n(1)") + + }) + + vdiffr::expect_doppelganger("marginal-ss-form-con-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(attr(marg_post_x_cont1[["-1SD"]], "prior_samples"), freq = FALSE, main = "marginal prior x_cont1\n(-1)", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-10, 10)) + hist(attr(marg_post_x_cont1[["0SD"]], "prior_samples"), freq = FALSE, main = "marginal prior x_cont1\n(0)", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-10, 10)) + hist(attr(marg_post_x_cont1[["1SD"]], "prior_samples"), freq = FALSE, main = "marginal prior x_cont1\n(1)", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-10, 10)) + + }) + + + ### formula: treatment factor ---- + marg_post_x_fac2t <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_fac2t", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-form-fac.t", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 2)) + hist(marg_post_x_fac2t[["A"]], freq = FALSE, main = "marg_post_x_fac2t = A") + hist(marg_post_x_fac2t[["B"]], freq = FALSE, main = "marg_post_x_fac2t = B", breaks = 20) + + }) + + vdiffr::expect_doppelganger("marginal-ss-form-fac.t-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 2)) + hist(attr(marg_post_x_fac2t[["A"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac2t = A", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x), add = TRUE) + hist(attr(marg_post_x_fac2t[["B"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac2t = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, (sqrt(1^2 + 0^2) + sqrt(1^2 + 1^2)) / 2), add = TRUE) + }) + + + ### formula: meandif factor ---- + marg_post_x_fac3md <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_fac3md", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-form-fac.md", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(marg_post_x_fac3md[["A"]], freq = FALSE, main = "marg_post_x_fac3md = A", breaks = 20) + hist(marg_post_x_fac3md[["B"]], freq = FALSE, main = "marg_post_x_fac3md = B", breaks = 20) + hist(marg_post_x_fac3md[["C"]], freq = FALSE, main = "marg_post_x_fac2t = B", breaks = 20) + }) + + vdiffr::expect_doppelganger("marginal-ss-form-fac.md-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(attr(marg_post_x_fac3md[["A"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac3md = A", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, (sqrt(1^2 + 0^2) + sqrt(1^2 + 0.25^2)) / 2), add = TRUE) + hist(attr(marg_post_x_fac3md[["B"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, (sqrt(1^2 + 0^2) + sqrt(1^2 + 0.25^2)) / 2), add = TRUE) + hist(attr(marg_post_x_fac3md[["C"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac3md = C", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, (sqrt(1^2 + 0^2) + sqrt(1^2 + 0.25^2)) / 2), add = TRUE) + }) + + + ### formula: meandif factor interaction ---- + marg_post_x_cont1__xXx__x_fac3md <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_cont1__xXx__x_fac3md", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-form-fac.mdi", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(3, 3)) + hist(marg_post_x_cont1__xXx__x_fac3md[["-1SD, A"]], freq = FALSE, main = "x_cont1 = -1\nmarg_post_x_fac3md = A", breaks = 20) + hist(marg_post_x_cont1__xXx__x_fac3md[["-1SD, B"]], freq = FALSE, main = "x_cont1 = -1\nmarg_post_x_fac3md = B", breaks = 20) + hist(marg_post_x_cont1__xXx__x_fac3md[["-1SD, C"]], freq = FALSE, main = "x_cont1 = -1\nmarg_post_x_fac3md = B", breaks = 20) + + hist(marg_post_x_cont1__xXx__x_fac3md[["0SD, A"]], freq = FALSE, main = "x_cont1 = 0\nmarg_post_x_fac3md = A", breaks = 20) + hist(marg_post_x_cont1__xXx__x_fac3md[["0SD, B"]], freq = FALSE, main = "x_cont1 = 0\nmarg_post_x_fac3md = B", breaks = 20) + hist(marg_post_x_cont1__xXx__x_fac3md[["0SD, C"]], freq = FALSE, main = "x_cont1 = 0\nmarg_post_x_fac3md = B", breaks = 20) + + hist(marg_post_x_cont1__xXx__x_fac3md[["1SD, A"]], freq = FALSE, main = "x_cont1 = 1\nmarg_post_x_fac3md = A", breaks = 20) + hist(marg_post_x_cont1__xXx__x_fac3md[["1SD, B"]], freq = FALSE, main = "x_cont1 = 1\nmarg_post_x_fac3md = B", breaks = 20) + hist(marg_post_x_cont1__xXx__x_fac3md[["1SD, C"]], freq = FALSE, main = "x_cont1 = 1\nmarg_post_x_fac3md = B", breaks = 20) + + }) + + vdiffr::expect_doppelganger("marginal-ss-form-fac.mdi-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(3, 3)) + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["-1SD, A"]], "prior_samples"), freq = FALSE, main = "x_cont1 = -1\nmarg_post_x_fac3md = A", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(0.5*sqrt(1^2 + 1^2 + 0.25^2 + 0.25^2)^2 + 0.5*sqrt(0.25^2 + 0.25^2))), add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["-1SD, B"]], "prior_samples"), freq = FALSE, main = "x_cont1 = -1\nmarg_post_x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(0.5*sqrt(1^2 + 1^2 + 0.25^2 + 0.25^2)^2 + 0.5*sqrt(0.25^2 + 0.25^2))), add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["-1SD, C"]], "prior_samples"), freq = FALSE, main = "x_cont1 = -1\nmarg_post_x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(0.5*sqrt(1^2 + 1^2 + 0.25^2 + 0.25^2)^2 + 0.5*sqrt(0.25^2 + 0.25^2))), add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["0SD, A"]], "prior_samples"), freq = FALSE, main = "x_cont1 = 0\nmarg_post_x_fac3md = A", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(1^2 + 0 + 0.25^2 + 0)) , add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["0SD, B"]], "prior_samples"), freq = FALSE, main = "x_cont1 = 0\nmarg_post_x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(1^2 + 0 + 0.25^2 + 0)) , add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["0SD, C"]], "prior_samples"), freq = FALSE, main = "x_cont1 = 0\nmarg_post_x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(1^2 + 0 + 0.25^2 + 0)) , add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["1SD, A"]], "prior_samples"), freq = FALSE, main = "x_cont1 = 1\nmarg_post_x_fac3md = A", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(0.5*sqrt(1^2 + 1^2 + 0.25^2 + 0.25^2)^2 + 0.5*sqrt(0.25^2 + 0.25^2))), add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["1SD, B"]], "prior_samples"), freq = FALSE, main = "x_cont1 = 1\nmarg_post_x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(0.5*sqrt(1^2 + 1^2 + 0.25^2 + 0.25^2)^2 + 0.5*sqrt(0.25^2 + 0.25^2))), add = TRUE) + + hist(attr(marg_post_x_cont1__xXx__x_fac3md[["1SD, C"]], "prior_samples"), freq = FALSE, main = "x_cont1 = 1\nmarg_post_x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + curve(dnorm(x, 0, sqrt(0.5*sqrt(1^2 + 1^2 + 0.25^2 + 0.25^2)^2 + 0.5*sqrt(0.25^2 + 0.25^2))), add = TRUE) + + }) + + + ### formula: meandif factor + at specification ---- + marg_post_x_fac3md_AT <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_fac3md", + at = list( + x_cont1 = 1, + x_fac2t = c("A", "B") + ), + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + + vdiffr::expect_doppelganger("marginal-ss-form-fac.md-at", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(3, 2)) + hist(marg_post_x_fac3md_AT[["A"]][1,], freq = FALSE, main = "marg_post_x_fac3md = A | 1,A", breaks = 20) + + hist(marg_post_x_fac3md_AT[["A"]][2,], freq = FALSE, main = "marg_post_x_fac3md = A | 1,B", breaks = 20) + + hist(marg_post_x_fac3md_AT[["B"]][1,], freq = FALSE, main = "marg_post_x_fac3md = B | 1,A", breaks = 20) + + hist(marg_post_x_fac3md_AT[["B"]][2,], freq = FALSE, main = "marg_post_x_fac3md = B | 1,B", breaks = 20) + + hist(marg_post_x_fac3md_AT[["C"]][1,], freq = FALSE, main = "marg_post_x_fac3md = C | 1,A", breaks = 20) + + hist(marg_post_x_fac3md_AT[["C"]][2,], freq = FALSE, main = "marg_post_x_fac3md = C | 1,B", breaks = 20) + + }) + + ### formula: transformation ---- + marg_post_x_cont1.exp <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_cont1", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + transformation = "exp", + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-form-con-exp", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(marg_post_x_cont1.exp[["-1SD"]], freq = FALSE, main = "exp marginal posterior x_cont1\n(-1)") + lines(density(exp(marg_post_x_cont1[["-1SD"]]))) + + hist(marg_post_x_cont1.exp[["0SD"]], freq = FALSE, main = "exp marginal posterior x_cont1\n(0)") + lines(density(exp(marg_post_x_cont1[["0SD"]]))) + + hist(marg_post_x_cont1.exp[["1SD"]], freq = FALSE, main = "exp marginal posterior x_cont1\n(1)") + lines(density(exp(marg_post_x_cont1[["1SD"]]))) + + }) + + vdiffr::expect_doppelganger("marginal-ss-form-con-p-exp", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + p.exp1 <- exp(attr(marg_post_x_cont1[["-1SD"]], "prior_samples")) + p.exp2 <- exp(attr(marg_post_x_cont1[["0SD"]], "prior_samples")) + p.exp3 <- exp(attr(marg_post_x_cont1[["1SD"]], "prior_samples")) + + par(mfrow = c(1, 3)) + hist(attr(marg_post_x_cont1.exp[["-1SD"]], "prior_samples"), freq = FALSE, main = "marginal prior x_cont1\n(-1)", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-10, 10)) + lines(density(p.exp1[p.exp1 < 10])) + + hist(exp(attr(marg_post_x_cont1[["0SD"]], "prior_samples")), freq = FALSE, main = "marginal prior x_cont1\n(0)", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-10, 10)) + lines(density(p.exp2[p.exp2 < 10])) + + hist(attr(marg_post_x_cont1.exp[["1SD"]], "prior_samples"), freq = FALSE, main = "marginal prior x_cont1\n(1)", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-10, 10)) + lines(density(p.exp3[p.exp3 < 10])) + }) + + ### conditional marginal samples ---- + mixed_posteriors <- as_mixed_posteriors( + model = fit, + parameters = c("sigma", "mu_intercept", "mu_x_cont1", "mu_x_fac2t", "mu_x_fac3md", "mu_x_cont1__xXx__x_fac3md"), + conditional = c("mu_x_cont1", "mu_x_fac3md"), + conditional_rule = "AND" + ) + marg_post_sigma <- marginal_posterior( + samples = mixed_posteriors, + parameter = "mu_x_fac3md", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + prior_samples = TRUE) + + vdiffr::expect_doppelganger("marginal-ss-cond-fac", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(2, 3)) + hist(marg_post_sigma[["A"]], freq = FALSE, main = "marg_post_x_fac2t = A") + hist(marg_post_sigma[["B"]], freq = FALSE, main = "marg_post_x_fac2t = B") + hist(marg_post_sigma[["C"]], freq = FALSE, main = "marg_post_x_fac2t = C") + + hist(attr(marg_post_sigma[["A"]], "prior"), freq = FALSE, main = "marg_post_x_fac2t = A") + curve(dnorm(x, 0, sqrt(1^2 + 0.25^2)), add = TRUE) + hist(attr(marg_post_sigma[["B"]], "prior"), freq = FALSE, main = "marg_post_x_fac2t = B") + curve(dnorm(x, 0, sqrt(1^2 + 0.25^2)), add = TRUE) + hist(attr(marg_post_sigma[["C"]], "prior"), freq = FALSE, main = "marg_post_x_fac2t = C") + curve(dnorm(x, 0, sqrt(1^2 + 0.25^2)), add = TRUE) + }) + + ### marginal_inference ---- + out <- as_marginal_inference( + model = fit, + parameters = c("sigma", "mu_intercept", "mu_x_cont1", "mu_x_fac2t", "mu_x_fac3md", "mu_x_cont1__xXx__x_fac3md"), + marginal_parameters = c("mu_intercept", "mu_x_cont1", "mu_x_fac2t", "mu_x_fac3md", "mu_x_cont1__xXx__x_fac3md"), + conditional_list = list( + "mu_intercept" = c(), + "mu_x_cont1" = c("mu_x_cont1"), + "mu_x_fac2t" = c("mu_x_cont1", "mu_x_fac2t"), + "mu_x_fac3md" = c("mu_x_fac3md"), + "mu_x_cont1__xXx__x_fac3md" = c("mu_x_fac2t", "mu_x_fac3md","mu_x_cont1__xXx__x_fac3md") + ), + conditional_rule = "OR", + formula = ~ x_cont1 + x_fac2t + x_cont1*x_fac3md, + silent = TRUE + ) + + # test samples against previously generated ones + vdiffr::expect_doppelganger("marginal_inference-ss-cont", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(marg_post_x_cont1[["-1SD"]], freq = FALSE, main = "mu_x_cont1 = -1SD", breaks = 20) + lines(density(out$averaged$mu_x_cont1[["-1SD"]])) + + hist(marg_post_x_cont1[["0SD"]], freq = FALSE, main = "mu_x_cont1 = 0SD", breaks = 20) + lines(density(out$averaged$mu_x_cont1[["0SD"]])) + + hist(marg_post_x_cont1[["1SD"]], freq = FALSE, main = "mu_x_cont1 = +1SD", breaks = 20) + lines(density(out$averaged$mu_x_cont1[["1SD"]])) + + }) + vdiffr::expect_doppelganger("marginal_inference-ss-cont-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(attr(marg_post_x_cont1[["-1SD"]], "prior_samples"), freq = FALSE, main = "mu_x_cont1 = -1SD", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + lines(density(attr(out$averaged$mu_x_cont1[["-1SD"]], "prior_samples"))) + hist(attr(marg_post_x_cont1[["0SD"]], "prior_samples"), freq = FALSE, main = "mu_x_cont1 = 0SD", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + lines(density(attr(out$averaged$mu_x_cont1[["0SD"]], "prior_samples"))) + hist(attr(marg_post_x_cont1[["1SD"]], "prior_samples"), freq = FALSE, main = "mu_x_cont1 = 1SD", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + lines(density(attr(out$averaged$mu_x_cont1[["1SD"]], "prior_samples"))) + }) + vdiffr::expect_doppelganger("marginal_inference-ss-fac.md", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(marg_post_x_fac3md[["A"]], freq = FALSE, main = "marg_post_x_fac3md = A", breaks = 20) + lines(density(out$averaged$mu_x_fac3md$A)) + + hist(marg_post_x_fac3md[["B"]], freq = FALSE, main = "marg_post_x_fac3md = B", breaks = 20) + lines(density(out$averaged$mu_x_fac3md$B)) + + hist(marg_post_x_fac3md[["C"]], freq = FALSE, main = "marg_post_x_fac3md = C", breaks = 20) + lines(density(out$averaged$mu_x_fac3md$C)) + + }) + vdiffr::expect_doppelganger("marginal_inference-ss-fac.md-p", function(){ + + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mfrow = oldpar[["mfrow"]])) + + par(mfrow = c(1, 3)) + hist(attr(marg_post_x_fac3md[["A"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac3md = A", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + lines(density(attr(out$averaged$mu_x_fac3md$A, "prior_samples"))) + hist(attr(marg_post_x_fac3md[["B"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac3md = B", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + lines(density(attr(out$averaged$mu_x_fac3md$B, "prior_samples"))) + hist(attr(marg_post_x_fac3md[["C"]], "prior_samples"), freq = FALSE, main = "marginal prior x_fac3md = C", breaks = c(-Inf, seq(-10, 10, 0.25), Inf), xlim = c(-5, 5), ylim = c(0, 0.4)) + lines(density(attr(out$averaged$mu_x_fac3md$C, "prior_samples"))) + }) + # the previous BFs were based on model-averaged posteriors so they won't match + + # test summary table (note that these differ from the first set of tests because of the different model settings) + expect_equal( + capture_output_lines(marginal_estimates_table(out$conditional, out$inference, parameters = c("mu_intercept", "mu_x_cont1", "mu_x_fac2t", "mu_x_fac3md", "mu_x_cont1__xXx__x_fac3md")), print = TRUE, width = 150), + c(" Mean Median 0.025 0.95 Inclusion BF" , + "(mu) intercept 0.617 0.617 0.542 0.681 Inf" , + "(mu) x_cont1[-1SD] 0.435 0.434 0.320 0.531 Inf" , + "(mu) x_cont1[0SD] 0.617 0.617 0.542 0.681 Inf" , + "(mu) x_cont1[1SD] 0.800 0.799 0.691 0.890 Inf" , + "(mu) x_fac2t[A] 0.617 0.617 0.542 0.681 Inf" , + "(mu) x_fac2t[B] 0.618 0.617 0.542 0.682 Inf" , + "(mu) x_fac3md[A] 0.778 0.778 0.651 0.886 Inf" , + "(mu) x_fac3md[B] 0.518 0.518 0.390 0.625 Inf" , + "(mu) x_fac3md[C] 0.554 0.554 0.427 0.662 Inf" , + "(mu) x_cont1:x_fac3md[-1SD, A] 0.590 0.592 0.407 0.729 Inf" , + "(mu) x_cont1:x_fac3md[0SD, A] 0.774 0.776 0.623 0.884 Inf" , + "(mu) x_cont1:x_fac3md[1SD, A] 0.958 0.959 0.802 1.084 Inf" , + "(mu) x_cont1:x_fac3md[-1SD, B] 0.342 0.341 0.182 0.483 158.472" , + "(mu) x_cont1:x_fac3md[0SD, B] 0.521 0.520 0.392 0.631 Inf" , + "(mu) x_cont1:x_fac3md[1SD, B] 0.700 0.699 0.549 0.827 Inf" , + "(mu) x_cont1:x_fac3md[-1SD, C] 0.375 0.374 0.226 0.501 Inf" , + "(mu) x_cont1:x_fac3md[0SD, C] 0.556 0.556 0.428 0.663 Inf" , + "(mu) x_cont1:x_fac3md[1SD, C] 0.737 0.738 0.579 0.871 Inf" , + "\033[0;31mmu_intercept: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1[-1SD]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1[0SD]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1[1SD]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_fac2t[A]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_fac2t[B]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_fac3md[A]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_fac3md[B]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_fac3md[C]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1__xXx__x_fac3md[-1SD, A]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m", + "\033[0;31mmu_x_cont1__xXx__x_fac3md[0SD, A]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1__xXx__x_fac3md[1SD, A]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1__xXx__x_fac3md[0SD, B]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1__xXx__x_fac3md[1SD, B]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1__xXx__x_fac3md[-1SD, C]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m", + "\033[0;31mmu_x_cont1__xXx__x_fac3md[0SD, C]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" , + "\033[0;31mmu_x_cont1__xXx__x_fac3md[1SD, C]: Posterior samples do not span both sides of the null hypothesis. The Savage-Dickey density ratio is likely to be overestimated.\033[0m" + )) + + # plots + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_fac2t-1", function(){plot_marginal(out$conditional, parameter = "mu_x_fac2t")}) + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_fac2t-2", function(){plot_marginal(out$conditional, parameter = "mu_x_fac2t", par_name = "fac2t", lwd = 2)}) + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_fac2t-3", function(){plot_marginal(out$conditional, parameter = "mu_x_fac2t", prior = TRUE, dots_prior = list(lty = 2))}) + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_fac2t-4", function(){plot_marginal(out$conditional, parameter = "mu_x_fac2t", prior = TRUE, dots_prior = list(lty = 2), xlim = c(0, 1))}) + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_fac2t-5", function(){plot_marginal(out$conditional, parameter = "mu_x_fac2t", prior = TRUE, dots_prior = list(lty = 2), transformation = "exp", xlim = c(0, 5), transformation_settings = T)}) + + vdiffr::expect_doppelganger("ggplot_marginal-ss-mu_x_fac2t-1", plot_marginal(out$conditional, plot_type = "ggplot", parameter = "mu_x_fac2t")) + vdiffr::expect_doppelganger("ggplot_marginal-ss-mu_x_fac2t-2", plot_marginal(out$conditional, plot_type = "ggplot", parameter = "mu_x_fac2t", par_name = "fac2t", lwd = 2)) + vdiffr::expect_doppelganger("ggplot_marginal-ss-mu_x_fac2t-3", plot_marginal(out$conditional, plot_type = "ggplot", parameter = "mu_x_fac2t", prior = TRUE, dots_prior = list(lty = 2))) + vdiffr::expect_doppelganger("ggplot_marginal-ss-mu_x_fac2t-4", plot_marginal(out$conditional, plot_type = "ggplot", parameter = "mu_x_fac2t", prior = TRUE, dots_prior = list(lty = 2), xlim = c(0, 1))) + + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_cont1", function(){plot_marginal(out$conditional, parameter = "mu_x_cont1", prior = TRUE, dots_prior = list(lty = 2), xlim = c(0, 1))}) + vdiffr::expect_doppelganger("ggplot_marginal-ss-mu_x_cont1", plot_marginal(out$conditional, plot_type = "ggplot", parameter = "mu_x_cont1", prior = TRUE, dots_prior = list(lty = 2), xlim = c(0, 1))) + + vdiffr::expect_doppelganger("plot_marginal-ss-mu_x_fac3md", function(){plot_marginal(out$averaged, parameter = "mu_x_fac3md", prior = TRUE, dots_prior = list(lty = 2), xlim = c(-1, 1))}) + vdiffr::expect_doppelganger("ggplot_marginal-ss-mu_x_fac3md", plot_marginal(out$averaged, plot_type = "ggplot", parameter = "mu_x_fac3md", prior = TRUE, dots_prior = list(lty = 2), xlim = c(-1, 1))) + + vdiffr::expect_doppelganger("plot_marginal-ss-int", plot_marginal(out$averaged, plot_type = "ggplot", parameter = "mu_intercept", prior = TRUE, dots_prior = list(lty = 2), xlim = c(-1, 1))) + +}) diff --git a/tests/testthat/test-model-averaging-plots.R b/tests/testthat/test-model-averaging-plots.R index 4ff8441c..0e723930 100644 --- a/tests/testthat/test-model-averaging-plots.R +++ b/tests/testthat/test-model-averaging-plots.R @@ -1642,4 +1642,282 @@ test_that("models plot functions work (formulas + spike factors)", { plot_models(model_list = models, samples = mixed_posteriors, inference = inference, parameter = "mu_x_fac3md", prior = TRUE) }) +}) + + +test_that("posterior plot model averaging based on complex single JAGS models (formulas + spike factors + mixture)", { + + set.seed(1) + + data_formula <- data.frame( + x_cont1 = rnorm(300), + x_fac2t = factor(rep(c("A", "B"), 150), levels = c("A", "B")), + x_fac3t = factor(rep(c("A", "B", "C"), 100), levels = c("A", "B", "C")) + ) + data <- list( + y = rnorm(300, -0.15 + 0.20 * data_formula$x_cont1 + ifelse(data_formula$x_fac3t == "A", 0.0, ifelse(data_formula$x_fac3t == "B", -0.2, 0.2)), ifelse(data_formula$x_fac2t == "A", 0.5, 1)), + N = 300 + ) + + # create model with mix of a formula and free parameters --- + formula_list1 <- list( + mu = ~ x_cont1 + x_fac2t + x_fac3t + ) + formula_data_list1 <- list( + mu = data_formula + ) + formula_prior_list1 <- list( + mu = list( + "intercept" = prior_mixture( + list( + prior("spike", list(0), prior_weights = 2), + prior("normal", list(-1, 0.5), prior_weights = 1), + prior("normal", list( 1, 0.5), prior_weights = 1) + ), + is_null = c(T, F, F) + ), + "x_cont1" = prior_spike_and_slab(prior("normal", list(0, 1), prior_weights = 1)), + "x_fac2t" = prior_mixture(list( + prior("spike", list(0), prior_weights = 1), + prior_factor("mnormal", list(0, 1), contrast = "orthonormal") + ), + is_null = c(T, F) + ), + "x_fac3t" = prior_mixture(list( + prior("spike", list(0), prior_weights = 1), + prior_factor("mnormal", list(0, 1), contrast = "orthonormal") + ), + is_null = c(T, F) + ) + ) + ) + + attr(formula_prior_list1$mu$x_cont1, "multiply_by") <- "sigma" + prior_list1 <- list( + "sigma" = prior_mixture( + list( + prior("normal", list(0, 1), truncation = list(0, Inf)), + prior("lognormal", list(0, 1)) + ), + components = c("normal", "lognormal") + ), + "bias" = prior_mixture(list( + prior_none(prior_weights = 1), + prior_weightfunction(distribution = "two.sided", parameters = list(alpha = c(1, 1), steps = c(0.05)), prior_weights = 1/3), + prior_weightfunction(distribution = "one.sided", parameters = list(alpha = c(1, 1, 1), steps = c(0.025, 0.05)), prior_weights = 1/3), + prior_PET("normal", list(0, 1), prior_weights = 1/3) + ), is_null = c(T, F, F, F)) + ) + model_syntax1 <- paste0( + "model{\n", + "for(i in 1:N){\n", + " y[i] ~ dnorm(mu[i], 1/pow(sigma, 2))\n", + "}\n", + "}" + ) + + if("RoBMA" %in% rownames(installed.packages())){ + require("RoBMA") + }else{ + skip() + } + + fit1 <- JAGS_fit( + model_syntax = model_syntax1, data = data, prior_list = prior_list1, + formula_list = formula_list1, formula_data_list = formula_data_list1, formula_prior_list = formula_prior_list1) + + mixed_posteriors <- as_mixed_posteriors( + mode = fit1, + parameters = names(attr(fit1, "prior_list")) + ) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-intercept", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors, "mu_intercept", prior = T, dots_prior = list(col = "grey")) + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-x_cont1", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors, "mu_x_cont1", prior = T, dots_prior = list(col = "grey")) + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-x_fac2t", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors, "mu_x_fac2t", prior = T, dots_prior = list(col = "grey")) + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-x_fac3t", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors, "mu_x_fac3t", prior = T, dots_prior = list(col = "grey")) + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-sigma", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors, "sigma", prior = T, dots_prior = list(col = "grey")) + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-bias-PET", function(){ + PET <- mixed_posteriors$bias[,"PET",drop=FALSE] + attributes(PET) <- c(attributes(PET), attributes(mixed_posteriors$bias)[!names(attributes(mixed_posteriors$bias)) %in% c("dimnames", "dim")]) + attr(PET, "prior_list")[!sapply(attr(PET, "prior_list"), is.prior.PET)] <- lapply(1:sum(!sapply(attr(PET, "prior_list"), is.prior.PET)), function(i) prior("point", list(0))) + attr(PET, "prior_list")[ sapply(attr(PET, "prior_list"), is.prior.PET)] <- lapply(attr(PET, "prior_list")[sapply(attr(PET, "prior_list"), is.prior.PET)], function(p) { + class(p) <- class(p)[!class(p) %in% "prior.PET"] + return(p) + }) + plot_posterior(list(PET = PET), "PET", prior = T, dots_prior = list(col = "grey")) + }) + + + mixed_posteriors_conditional1 <- as_mixed_posteriors( + mode = fit1, + parameters = "mu_intercept", + conditional = "mu_intercept", + force_plots = TRUE + ) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-intercept-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors_conditional1, "mu_intercept", prior = TRUE, dots_prior = list(col = "grey")) + }) + + mixed_posteriors_conditional2 <- as_mixed_posteriors( + mode = fit1, + parameters = "mu_x_cont1", + conditional = "mu_x_cont1", + force_plots = TRUE + ) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-x_cont1-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors_conditional2, "mu_x_cont1", prior = TRUE, dots_prior = list(col = "grey")) + }) + + mixed_posteriors_conditional3 <- as_mixed_posteriors( + mode = fit1, + parameters = "mu_x_fac2t", + conditional = "mu_x_fac2t", + force_plots = TRUE + ) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-x_fac2t-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors_conditional3, "mu_x_fac2t", prior = TRUE, dots_prior = list(col = "grey")) + }) + + mixed_posteriors_conditional4 <- as_mixed_posteriors( + mode = fit1, + parameters = "mu_x_fac3t", + conditional = "mu_x_fac3t", + force_plots = TRUE + ) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-x_fac3t-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors_conditional4, "mu_x_fac3t", prior = TRUE, dots_prior = list(col = "grey")) + }) + + + mixed_posteriors_conditional5a <- as_mixed_posteriors( + mode = fit1, + parameters = "bias" + ) + + mixed_posteriors_conditional5b <- as_mixed_posteriors( + mode = fit1, + parameters = "bias", + conditional = "bias", + force_plots = TRUE + ) + + mixed_posteriors_conditional6a <- as_mixed_posteriors( + mode = fit1, + parameters = "bias", + conditional = "PET", + force_plots = TRUE + ) + + mixed_posteriors_conditional6b <- as_mixed_posteriors( + mode = fit1, + parameters = "bias", + conditional = "omega", + force_plots = TRUE + ) + + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-weightfunction", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors_conditional5a, parameter = "weightfunction", prior = TRUE, col = "black", col.fill = ggplot2::alpha("grey", 0.2), dots_prior = list(col = "red", col.fill = ggplot2::alpha("red", 0.5))) + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-weightfunction-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4)) + plot_posterior(mixed_posteriors_conditional6b, parameter = "weightfunction", prior = TRUE, col = "black", col.fill = ggplot2::alpha("grey", 0.2), dots_prior = list(col = "red", col.fill = ggplot2::alpha("red", 0.5))) + }) + +# # TODO: at some point +# vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-PETPEESE", function(){ +# oldpar <- graphics::par(no.readonly = TRUE) +# on.exit(graphics::par(mar = oldpar[["mar"]])) +# par(mar = c(4, 4, 1, 4)) +# plot_posterior(mixed_posteriors_conditional5a, parameter = "PETPEESE", prior = TRUE, col = "black", col.fill = ggplot2::alpha("grey", 0.2), dots_prior = list(col = "red", col.fill = ggplot2::alpha("red", 0.5))) +# }) +# +# vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-PETPEESE-con", function(){ +# oldpar <- graphics::par(no.readonly = TRUE) +# on.exit(graphics::par(mar = oldpar[["mar"]])) +# par(mar = c(4, 4, 1, 4)) +# plot_posterior(mixed_posteriors_conditional6b, parameter = "PETPEESE", prior = TRUE, col = "black", col.fill = ggplot2::alpha("grey", 0.2), dots_prior = list(col = "red", col.fill = ggplot2::alpha("red", 0.5))) +# }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-PET-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4), mfrow = c(3, 1)) + hist(mixed_posteriors_conditional5a$bias[,"PET"], breaks = 50, col = "grey", main = "PET", xlab = "PET") + hist(mixed_posteriors_conditional5b$bias[,"PET"], breaks = 50, col = "grey", main = "PET", xlab = "PET") + hist(mixed_posteriors_conditional6a$bias[,"PET"], breaks = 50, col = "grey", main = "PET", xlab = "PET") + }) + + vdiffr::expect_doppelganger("model-averaging-plot-ss-posterior-omega-con", function(){ + oldpar <- graphics::par(no.readonly = TRUE) + on.exit(graphics::par(mar = oldpar[["mar"]])) + par(mar = c(4, 4, 1, 4), mfrow = c(3, 3)) + hist(mixed_posteriors_conditional5a$bias[,"omega[0,0.025]"], breaks = 50, col = "grey", main = "omega[0,0.025]", xlab = "omega[0,0.025]") + hist(mixed_posteriors_conditional5a$bias[,"omega[0.025,0.05]"], breaks = 50, col = "grey", main = "omega[0.025,0.05]", xlab = "omega[0.025,0.05]") + hist(mixed_posteriors_conditional5a$bias[,"omega[0.05,0.975]"], breaks = 50, col = "grey", main = "omega[0.05,0.975]", xlab = "omega[0.05,0.975]") + + hist(mixed_posteriors_conditional5b$bias[,"omega[0,0.025]"], breaks = 50, col = "grey", main = "omega[0,0.025]", xlab = "omega[0,0.025]") + hist(mixed_posteriors_conditional5b$bias[,"omega[0.025,0.05]"], breaks = 50, col = "grey", main = "omega[0.025,0.05]", xlab = "omega[0.025,0.05]") + hist(mixed_posteriors_conditional5b$bias[,"omega[0.05,0.975]"], breaks = 50, col = "grey", main = "omega[0.05,0.975]", xlab = "omega[0.05,0.975]") + + hist(mixed_posteriors_conditional6b$bias[,"omega[0,0.025]"], breaks = 50, col = "grey", main = "omega[0,0.025]", xlab = "omega[0,0.025]") + hist(mixed_posteriors_conditional6b$bias[,"omega[0.025,0.05]"], breaks = 50, col = "grey", main = "omega[0.025,0.05]", xlab = "omega[0.025,0.05]") + hist(mixed_posteriors_conditional6b$bias[,"omega[0.05,0.975]"], breaks = 50, col = "grey", main = "omega[0.05,0.975]", xlab = "omega[0.05,0.975]") + }) + + + + }) diff --git a/tests/testthat/test-priors-print.R b/tests/testthat/test-priors-print.R index e8dd139e..c5a9df63 100644 --- a/tests/testthat/test-priors-print.R +++ b/tests/testthat/test-priors-print.R @@ -124,10 +124,45 @@ test_that("Prior print function works", { p21 <- prior_spike_and_slab(prior("gamma", list(1, 2), list(0, Inf)), prior_inclusion = prior("beta", list(3, 2))) + p22 <- prior_mixture( + list( + prior("normal", list(0, 1)), + prior("normal", list(-3, 1)), + prior("gamma", list(5, 10)) + ) + ) + p23 <- prior_mixture( + list( + prior("normal", list(0, 1), prior_weights = 1), + prior("normal", list(-3, 1), prior_weights = 5), + prior("gamma", list(5, 10), prior_weights = 1) + ), + is_null = c(T, F, T) + ) + p24 <- prior_mixture( + list( + prior("normal", list(0, 1), prior_weights = 1), + prior("normal", list(-3, 1), prior_weights = 5) + ), + components = c("b", "a") + ) + expect_equal(utils::capture.output(print(p21)), "Gamma(1, 2) * Beta(3, 2)") expect_equal(utils::capture.output(print(p21, short_name = TRUE)), "G(1, 2) * B(3, 2)") + expect_equal(utils::capture.output(print(p22, parameter_names = TRUE)), c( + "alternative:", " (1/3) * Normal(mean = 0, sd = 1)", " (1/3) * Normal(mean = -3, sd = 1)", " (1/3) * Gamma(shape = 5, rate = 10)" + )) + expect_equal(utils::capture.output(print(p23, short_name = TRUE)), c( + "alternative:", " (1/7) * N(0, 1)", "null:", " (5/7) * N(-3, 1)", " (1/7) * G(5, 10)" + )) + expect_equal(utils::capture.output(print(p24)), c( + "b:", " (1/6) * Normal(0, 1)", "a:", " (5/6) * Normal(-3, 1)" + )) vdiffr::expect_doppelganger("priors-print-4", function(){ empty_plot() text(0.5, 1, print(p21, plot = TRUE)) + text(0.5, 0.9, print(p22, plot = TRUE)) + text(0.5, 0.8, print(p23, plot = TRUE)) + text(0.5, 0.7, print(p24, plot = TRUE)) }) }) diff --git a/tests/testthat/test-priors.R b/tests/testthat/test-priors.R index e6fc96a4..1be5a549 100644 --- a/tests/testthat/test-priors.R +++ b/tests/testthat/test-priors.R @@ -22,12 +22,13 @@ test_prior <- function(prior, skip_moments = FALSE){ } # tests density function lines(prior, individual = TRUE) + # tests quantile function - if(!is.prior.spike_and_slab(prior)){ + if(!is.prior.spike_and_slab(prior) && !is.prior.mixture(prior)){ abline(v = quant(prior, 0.5), col = "blue", lwd = 2) } # tests that pdf(q(x)) == x - if(!is.prior.point(prior) & !is.prior.discrete(prior) & !is.prior.spike_and_slab(prior)){ + if(!is.prior.point(prior) && !is.prior.discrete(prior) && !is.prior.spike_and_slab(prior) && !is.prior.mixture(prior)){ expect_equal(.25, cdf(prior, quant(prior, 0.25)), tolerance = 1e-4) expect_equal(.25, ccdf(prior, quant(prior, 0.75)), tolerance = 1e-4) } @@ -328,3 +329,52 @@ test_that("Meandif prior distribution works", { vdiffr::expect_doppelganger("prior-meandif-2-5", function()test_meandif(p2.5)) }) + +test_that("Prior mixture distributions work", { + + p1 <- prior_mixture( + list( + prior("normal", list(0, 1)), + prior("normal", list(-3, 1)), + prior("gamma", list(5, 10)) + ) + ) + p2 <- prior_mixture( + list( + prior("normal", list(0, 1), prior_weights = 1), + prior("normal", list(-3, 1), prior_weights = 5), + prior("gamma", list(5, 10), prior_weights = 1) + ), + is_null = c(T, F, T) + ) + p3 <- prior_mixture( + list( + prior("normal", list(0, 1), prior_weights = 1), + prior("normal", list(-3, 1), prior_weights = 5) + ), + components = c("b", "a") + ) + + vdiffr::expect_doppelganger("prior-mixture-1", function()test_prior(p1, skip_moments = TRUE)) + vdiffr::expect_doppelganger("prior-mixture-2", function()test_prior(p2, skip_moments = TRUE)) + vdiffr::expect_doppelganger("prior-mixture-3", function()test_prior(p3, skip_moments = TRUE)) + + + # random number generator from complex mixture priors + p4 <- prior_mixture(list( + prior("spike", list(0), prior_weights = 1), + prior_factor("mnormal", list(0, 10), contrast = "orthonormal", prior_weights = 3), + prior_factor("mnormal", list(0, 1), contrast = "orthonormal") + ), + is_null = c(T, F, F) + ) + + for(i in seq_along(p4)){ + p4[[i]]$parameters[["K"]] <- 3 + } + + + vdiffr::expect_doppelganger("prior-mixture-4", function()hist(rng(p4, 10000, transform_factor_samples = FALSE), main = print(p4, plot = T), breaks = 50, freq = FALSE)) + vdiffr::expect_doppelganger("prior-mixture-5", function()hist(rng(p4, 10000, transform_factor_samples = TRUE), main = print(p4, plot = T), breaks = 50, freq = FALSE)) + +}) diff --git a/tests/testthat/test-summary-tables.R b/tests/testthat/test-summary-tables.R index f243a290..9c6657ca 100644 --- a/tests/testthat/test-summary-tables.R +++ b/tests/testthat/test-summary-tables.R @@ -56,7 +56,7 @@ test_that("Summary tables functions work",{ runjags_summary <- models[[2]]$fit_summary expect_equal(colnames(runjags_summary), c("Mean", "SD", "lCI", "Median", "uCI", "MCMC_error", "MCMC_SD_error", "ESS", "R_hat")) expect_equal(rownames(runjags_summary), c("m", "omega[0,0.05]", "omega[0.05,1]")) - expect_equal(unname(unlist(runjags_summary[1,])), c(0.155080816, 0.197817354, -0.247495448, 0.167295089, 0.496803251, 0.009208408, 0.047000000, 461.000000000, NA), tolerance = 1e-4) + expect_equal(unname(unlist(runjags_summary[1,])), c(0.155080816, 0.197817354, -0.247495448, 0.167295089, 0.496803251, 0.009208408, 0.0466 , 461.4872, NA), tolerance = 1e-4) # ensemble estimates estimates_table <- ensemble_estimates_table(mixed_posteriors, parameters = c("m", "omega"), probs = c(.025, 0.95)) @@ -92,14 +92,14 @@ test_that("Summary tables functions work",{ expect_equal(unname(as.vector(diagnostics_table[,3])), c("", "omega[one-sided: .05] ~ CumDirichlet(1, 1)", "omega[one-sided: .5, .05] ~ CumDirichlet(1, 1, 1)")) expect_equal(unname(as.vector(diagnostics_table[,4])), c(0.01019039, 0.01348211, 0.01061287), tolerance = 1e-4) expect_equal(unname(as.vector(diagnostics_table[,5])), c(0.048, 0.047, 0.045), tolerance = 1e-3) - expect_equal(unname(as.vector(diagnostics_table[,6])), c(434, 461, 500)) + expect_equal(unname(as.vector(diagnostics_table[,6])), c(434, 461, 500), tolerance = 1e-3) expect_equal(unname(as.vector(diagnostics_table[,7])), c(NA, NA, NA)) ### test additional settings # transformations runjags_summary2t <- runjags_estimates_table(fit2, transformations = list("m" = list(fun = exp))) - expect_equal(exp(models[[3]]$fit_summary[1,c("lCI","Median","uCI","MCMC_error")]), runjags_summary2t[1,c("lCI","Median","uCI","MCMC_error")], tolerance = 1e-5) + expect_equal(exp(as.data.frame(models[[3]]$fit_summary[1,c("lCI","Median","uCI")])), as.data.frame(runjags_summary2t[1,c("lCI","Median","uCI")]), tolerance = 1e-5) expect_equal(colnames(models[[3]]$fit_summary), colnames(runjags_summary2t)) expect_equal(rownames(models[[3]]$fit_summary), rownames(runjags_summary2t)) @@ -475,26 +475,26 @@ test_that("Summary tables functions work (formulas + factors)",{ expect_equal(unname(as.vector(diagnostics_table[,4])), c("", "", "", "orthonormal contrast: mNormal(0, 1)")) expect_equal(unname(as.vector(diagnostics_table[,5])), c(0.003223670, 0.004142589, 0.001676136, 0.001959310), tolerance = 1e-3) expect_equal(unname(as.vector(diagnostics_table[,6])), c(0.013, 0.017, 0.011, 0.011), tolerance = 1e-3) - expect_equal(unname(as.vector(diagnostics_table[,7])), c(5559, 3526, 8660, 7969)) + expect_equal(unname(as.vector(diagnostics_table[,7])), c(5559, 3526, 8660, 7969), tolerance = 1e-3) expect_equal(unname(as.vector(diagnostics_table[,8])), c(1.001154, 1.000955, 1.000125, 1.000658), tolerance = 1e-3) ### test additional settings # transformations of orthonormal contrast to differences from the mean - runjags_summary_t <- runjags_estimates_table(fit3, transform_factors = TRUE) + runjags_summary_t <- suppressMessages(runjags_estimates_table(fit3, transform_factors = TRUE)) expect_equal(colnames(runjags_summary_t), c("Mean", "SD", "lCI", "Median", "uCI", "MCMC_error", "MCMC_SD_error", "ESS", "R_hat")) expect_equal(rownames(runjags_summary_t), c("(mu) intercept","(mu) x_cont1","(mu) x_fac3o [dif: A]","(mu) x_fac3o [dif: B]","(mu) x_fac3o [dif: C]", "(mu) x_cont1:x_fac3o [dif: A]", "(mu) x_cont1:x_fac3o [dif: B]", "(mu) x_cont1:x_fac3o [dif: C]", "sigma" )) expect_equal(capture_output_lines(runjags_summary_t, print = TRUE, width = 150), c(" Mean SD lCI Median uCI error(MCMC) error(MCMC)/SD ESS R-hat", "(mu) intercept 0.188 0.121 -0.051 0.188 0.429 0.00099 0.008 14975 1.000", "(mu) x_cont1 0.324 0.140 0.047 0.324 0.597 0.00112 0.008 15680 1.000", - "(mu) x_fac3o [dif: A] -0.010 0.168 -0.337 -0.011 0.321 0.00132 0.008 15278 1.000", - "(mu) x_fac3o [dif: B] -0.064 0.170 -0.397 -0.064 0.270 0.00134 0.008 15081 1.000", - "(mu) x_fac3o [dif: C] 0.074 0.167 -0.251 0.072 0.404 0.00132 0.008 15630 1.000", - "(mu) x_cont1:x_fac3o [dif: A] -0.283 0.197 -0.668 -0.283 0.105 0.00156 0.008 15581 1.000", - "(mu) x_cont1:x_fac3o [dif: B] 0.164 0.194 -0.221 0.164 0.539 0.00153 0.008 14954 1.000", - "(mu) x_cont1:x_fac3o [dif: C] 0.119 0.202 -0.275 0.118 0.521 0.00160 0.008 15372 1.000", - "sigma 0.925 0.090 0.770 0.918 1.119 0.00100 0.011 7969 1.001" + "(mu) x_fac3o [dif: A] -0.010 0.168 -0.337 -0.011 0.321 0.00134 0.008 15720 1.000", + "(mu) x_fac3o [dif: B] -0.064 0.170 -0.397 -0.064 0.270 0.00139 0.008 14958 1.000", + "(mu) x_fac3o [dif: C] 0.074 0.167 -0.251 0.072 0.404 0.00133 0.008 15737 1.000", + "(mu) x_cont1:x_fac3o [dif: A] -0.283 0.197 -0.668 -0.283 0.105 0.00158 0.008 15659 1.000", + "(mu) x_cont1:x_fac3o [dif: B] 0.164 0.194 -0.221 0.164 0.539 0.00160 0.008 14777 1.000", + "(mu) x_cont1:x_fac3o [dif: C] 0.119 0.202 -0.275 0.118 0.521 0.00161 0.008 15778 1.000", + "sigma 0.925 0.090 0.770 0.918 1.119 0.00101 0.011 7969 1.001" )) @@ -512,12 +512,12 @@ test_that("Summary tables functions work (formulas + factors)",{ "(mu) x_cont1:x_fac3o [dif: C] 0.005 0.000 0.000 0.000" )) # transform estimates - runjags_summary_t2 <- runjags_estimates_table(fit1, transform_factors = FALSE, transformations = list("mu_x_fac2t" = list(fun = exp))) + runjags_summary_t2 <- suppressMessages(runjags_estimates_table(fit1, transform_factors = FALSE, transformations = list("mu_x_fac2t" = list(fun = exp)))) expect_equal(capture_output_lines(runjags_summary_t2, print = TRUE, width = 150), c(" Mean SD lCI Median uCI error(MCMC) error(MCMC)/SD ESS R-hat", "(mu) intercept 0.145 0.200 -0.245 0.144 0.541 0.00338 0.017 3526 1.001", "(mu) x_cont1 0.327 0.139 0.052 0.327 0.602 0.00111 0.008 15725 1.000", - "(mu) x_fac3t[B] 0.006 0.281 -0.550 0.011 0.550 0.00414 0.015 4596 1.001", + "(mu) x_fac3t[B] 0.006 0.281 -0.550 0.011 0.550 0.00415 0.015 4596 1.001", "(mu) x_fac3t[C] 0.118 0.277 -0.433 0.120 0.656 0.00407 0.015 4630 1.001", "sigma 0.926 0.089 0.774 0.918 1.117 0.00099 0.011 8016 1.000" )) @@ -541,7 +541,7 @@ test_that("Summary tables functions work (formulas + factors)",{ "(mu) x_fac3o[2] -0.012 0.205 -0.412 -0.013 0.393 0.00164 0.008 15720 1.000", "(mu) x_cont1:x_fac3o[1] -0.032 0.243 -0.507 -0.033 0.448 0.00196 0.008 15383 1.000", "(mu) x_cont1:x_fac3o[2] -0.347 0.242 -0.818 -0.347 0.128 0.00193 0.008 15659 1.000", - "sigma 0.925 0.090 0.770 0.918 1.119 0.00100 0.011 7969 1.001" + "sigma 0.925 0.090 0.770 0.918 1.119 0.00101 0.011 7969 1.001" )) expect_equal(capture_output_lines(estimates_table, print = TRUE, width = 150), @@ -571,8 +571,8 @@ test_that("Summary tables functions work (formulas + factors)",{ )) expect_equal(capture_output_lines(diagnostics_table, print = TRUE, width = 180), c(" Model Prior (mu) x_cont1 Prior (mu) x_fac3o Prior (mu) x_cont1:x_fac3o max[error(MCMC)] max[error(MCMC)/SD] min(ESS) max(R-hat)", - " 1 0.00322 0.013 5559 1.001", - " 2 Normal(0, 1) 0.00414 0.017 3526 1.001", + " 1 0.00323 0.013 5559 1.001", + " 2 Normal(0, 1) 0.00415 0.017 3526 1.001", " 3 orthonormal contrast: mNormal(0, 1) 0.00168 0.011 8660 1.000", " 4 Normal(0, 1) orthonormal contrast: mNormal(0, 1) orthonormal contrast: mNormal(0, 1) 0.00196 0.011 7969 1.001" )) @@ -710,7 +710,7 @@ test_that("Summary tables functions work (indepdent factors)",{ expect_equal(unname(as.vector(diagnostics_table[,2])), c("independent contrast: Spike(0)","independent contrast: Normal(0, 0.25)")) expect_equal(unname(as.vector(diagnostics_table[,3])), c(0.0008277888, 0.0010673515), tolerance = 1e-3) expect_equal(unname(as.vector(diagnostics_table[,4])), c(0.010, 0.011), tolerance = 1e-3) - expect_equal(unname(as.vector(diagnostics_table[,5])), c(9564, 8145)) + expect_equal(unname(as.vector(diagnostics_table[,5])), c(9564, 8145), tolerance = 1e-3) }) @@ -813,7 +813,7 @@ test_that("Summary tables functions work (meandif factors)",{ expect_equal(unname(unlist(runjags_summary[1,])), c(2.616574e-02,8.256672e-02,-1.369357e-01,2.621934e-02,1.851191e-01,6.471943e-04,8.000000e-03,1.627600e+04,9.999001e-01), tolerance = 1e-3) # ensemble estimates - estimates_table <- ensemble_estimates_table(mixed_posteriors, parameters = c("mu_x_fac3"), probs = c(.025, 0.95), transform_factors = TRUE) + estimates_table <- suppressMessages(ensemble_estimates_table(mixed_posteriors, parameters = c("mu_x_fac3"), probs = c(.025, 0.95), transform_factors = TRUE)) expect_equal(colnames(estimates_table), c("Mean", "Median", "0.025", "0.95")) expect_equal(rownames(estimates_table), c("(mu) x_fac3 [dif: A]", "(mu) x_fac3 [dif: B]", "(mu) x_fac3 [dif: C]")) expect_equal(unname(unlist(estimates_table[1,])), c(-0.2074503, -0.2206674, -0.4204564, 0.0000000), tolerance = 1e-3) @@ -846,7 +846,7 @@ test_that("Summary tables functions work (meandif factors)",{ expect_equal(unname(as.vector(diagnostics_table[,2])), c("", "mean difference contrast: mNormal(0, 0.2)")) expect_equal(unname(as.vector(diagnostics_table[,3])), c(0.0006707336, 0.0007978420), tolerance = 1e-3) expect_equal(unname(as.vector(diagnostics_table[,4])), c(0.01, 0.01), tolerance = 1e-3) - expect_equal(unname(as.vector(diagnostics_table[,5])), c(9676, 9871)) + expect_equal(unname(as.vector(diagnostics_table[,5])), c(9676, 9871), tolerance = 1e-3) }) @@ -901,23 +901,20 @@ test_that("Summary tables functions work (spike and slab priors)",{ "}" ) - log_posterior <- function(parameters, data){ - sum(stats::dnorm(data$y, parameters[["mu"]], parameters[["sigma"]], log = TRUE)) - } - fit0 <- JAGS_fit( model_syntax = model_syntax, data = data, prior_list = prior_list, formula_list = formula_list0, formula_data_list = formula_data_list, formula_prior_list = formula_prior_list0, seed = 1) + # bridge sampling cannot be computer for spike and slab priors - using a dummy value for marglik marglik0 <- list(logml = 0) class(marglik0) <- "bridge" + # mix posteriors models <- list( list(fit = fit0, marglik = marglik0, fit_summary = runjags_estimates_table(fit0), prior_weights = 1) ) models <- models_inference(models) - model_summary_table(models[[1]]) ### checking summary functions # model summary model_summary <- model_summary_table(models[[1]]) @@ -925,26 +922,52 @@ test_that("Summary tables functions work (spike and slab priors)",{ expect_equal(model_summary[,4], c("Parameter prior distributions", "(mu) intercept ~ Normal(0, 5)", "(mu) x_cont1 ~ Normal(0, 0.5) * Beta(1, 1)", "(mu) x_fac2t ~ treatment contrast: Normal(0, 1) * Beta(1, 1)", "(mu) x_fac3o ~ orthonormal contrast: mNormal(0, 1) * Spike(0.5)", "sigma ~ Lognormal(0, 1)")) model_estimates <- runjags_estimates_table(fit0) - expect_equal(colnames(model_estimates), c("Mean", "SD", "lCI", "Median", "uCI", "MCMC_error", "MCMC_SD_error", "ESS", "R_hat")) - expect_equal(rownames(model_estimates), c("(mu) intercept", "(mu) x_cont1", "(mu) x_cont1 (inclusion)", "(mu) x_fac2t[B]", "(mu) x_fac2t (inclusion)", "(mu) x_fac3o[1]", "(mu) x_fac3o[2]", "(mu) x_fac3o (inclusion)", "sigma")) - expect_equal(unname(unlist(model_estimates[7,])), c(-1.776437e-03, 4.269207e-02, 0.000000e+00, 0.000000e+00, 0.000000e+00, 3.428435e-04, 8.000000e-03, 1.550600e+04, 1.001065e+00), tolerance = 1e-3) - - model_estimates <- runjags_estimates_table(fit0, transform_factors = TRUE, conditional = TRUE) - expect_equal(colnames(model_estimates), c("Mean", "SD", "lCI", "Median", "uCI", "MCMC_error", "MCMC_SD_error", "ESS", "R_hat")) - expect_equal(rownames(model_estimates), c("(mu) intercept", "(mu) x_cont1", "(mu) x_cont1 (inclusion)", "(mu) x_fac2t[B]", "(mu) x_fac2t (inclusion)", "(mu) x_fac3o [dif: A]", "(mu) x_fac3o [dif: B]", "(mu) x_fac3o [dif: C]", "(mu) x_fac3o (inclusion)", "sigma")) - expect_equal(unname(unlist(model_estimates[8,])), c(0.0626582174, 0.1661778973, -0.2621073424, 0.0591205499, 0.3954805352, NA, NA, NA, NA), tolerance = 1e-3) - - model_estimates <- runjags_estimates_table(fit0, transform_factors = TRUE, conditional = TRUE, remove_inclusion = TRUE) - expect_equal(colnames(model_estimates), c("Mean", "SD", "lCI", "Median", "uCI", "MCMC_error", "MCMC_SD_error", "ESS", "R_hat")) - expect_equal(rownames(model_estimates), c("(mu) intercept", "(mu) x_cont1", "(mu) x_fac2t[B]", "(mu) x_fac3o [dif: A]", "(mu) x_fac3o [dif: B]", "(mu) x_fac3o [dif: C]", "sigma")) - expect_equal(unname(unlist(model_estimates[2,])), c(3.040927e-01, 1.355633e-01, 3.256895e-02, 3.058346e-01, 5.678668e-01, 2.298187e-03, 1.300000e-02, 5.720000e+03, 1.000421e+00), tolerance = 1e-3) + testthat::expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI error(MCMC) error(MCMC)/SD ESS R-hat", + "(mu) intercept 0.194 0.132 -0.072 0.195 0.456 0.00132 0.010 10084 1.000", + "(mu) x_cont1 (inclusion) 0.780 NA NA NA NA NA NA NA NA", + "(mu) x_cont1 0.237 0.174 0.000 0.256 0.555 0.00230 0.013 5720 1.000", + "(mu) x_fac2t (inclusion) 0.186 NA NA NA NA NA NA NA NA", + "(mu) x_fac2t[B] 0.006 0.105 -0.233 0.000 0.299 0.00123 0.012 7310 1.002", + "(mu) x_fac3o (inclusion) 0.040 NA NA NA NA NA NA NA NA", + "(mu) x_fac3o[1] 0.003 0.043 0.000 0.000 0.003 0.00034 0.008 15764 1.001", + "(mu) x_fac3o[2] -0.002 0.043 0.000 0.000 0.000 0.00035 0.008 15506 1.001", + "sigma 0.922 0.088 0.772 0.915 1.113 0.00095 0.011 8458 1.000" + )) + + model_estimates <- suppressMessages(runjags_estimates_table(fit0, transform_factors = TRUE, conditional = TRUE)) + testthat::expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI", + "(mu) intercept 0.194 0.132 -0.072 0.195 0.456", + "(mu) x_cont1 (inclusion) 0.780 NA NA NA NA", + "(mu) x_cont1 0.304 0.136 0.033 0.306 0.568", + "(mu) x_fac2t (inclusion) 0.186 NA NA NA NA", + "(mu) x_fac2t[B] 0.033 0.241 -0.435 0.031 0.507", + "(mu) x_fac3o (inclusion) 0.040 NA NA NA NA", + "(mu) x_fac3o [dif: A] -0.036 0.171 -0.359 -0.043 0.316", + "(mu) x_fac3o [dif: B] -0.026 0.173 -0.367 -0.026 0.296", + "(mu) x_fac3o [dif: C] 0.063 0.166 -0.262 0.059 0.395", + "sigma 0.922 0.088 0.772 0.915 1.113" + )) + + model_estimates <- suppressMessages(runjags_estimates_table(fit0, transform_factors = TRUE, conditional = TRUE, remove_inclusion = TRUE)) + testthat::expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI", + "(mu) intercept 0.194 0.132 -0.072 0.195 0.456", + "(mu) x_cont1 0.304 0.136 0.033 0.306 0.568", + "(mu) x_fac2t[B] 0.033 0.241 -0.435 0.031 0.507", + "(mu) x_fac3o [dif: A] -0.036 0.171 -0.359 -0.043 0.316", + "(mu) x_fac3o [dif: B] -0.026 0.173 -0.367 -0.026 0.296", + "(mu) x_fac3o [dif: C] 0.063 0.166 -0.262 0.059 0.395", + "sigma 0.922 0.088 0.772 0.915 1.113" + )) model_inference <- runjags_inference_table(fit0) - expect_equal(colnames(model_inference), c("Parameter", "prior_prob", "post_prob", "inclusion_BF")) - expect_equal(model_inference[,1], c("(mu) x_cont1", "(mu) x_fac2t", "(mu) x_fac3o")) - expect_equal(model_inference[,2], c(0.5, 0.5, 0.5)) - expect_equal(model_inference[,3], c(0.7798125, 0.1864375, 0.0399375), tolerance = 1e-3) - expect_equal(model_inference[,4], c(3.54158388, 0.22916187, 0.04159885), tolerance = 1e-3) + expect_equal(colnames(model_inference), c("prior_prob", "post_prob", "inclusion_BF")) + expect_equal(rownames(model_inference), c("(mu) x_cont1", "(mu) x_fac2t", "(mu) x_fac3o")) + expect_equal(model_inference[,1], c(0.5, 0.5, 0.5)) + expect_equal(model_inference[,2], c(0.7798125, 0.1864375, 0.0399375), tolerance = 1e-3) + expect_equal(model_inference[,3], c(3.54158388, 0.22916187, 0.04159885), tolerance = 1e-3) runjags_inference_empty <- runjags_inference_empty_table() expect_equivalent(nrow(runjags_inference_empty), 0) @@ -1051,8 +1074,8 @@ test_that("Summary tables functions work (spike factors)",{ # mix posteriors models <- list( - list(fit = fit0, marglik = marglik0, fit_summary = runjags_estimates_table(fit0, remove_spike_0 = FALSE, transform_factors = TRUE), prior_weights = 1), - list(fit = fit1, marglik = marglik1, fit_summary = runjags_estimates_table(fit1, remove_spike_0 = FALSE, transform_factors = TRUE), prior_weights = 1) + list(fit = fit0, marglik = marglik0, fit_summary = suppressMessages(runjags_estimates_table(fit0, remove_spike_0 = FALSE, transform_factors = TRUE)), prior_weights = 1), + list(fit = fit1, marglik = marglik1, fit_summary = suppressMessages(runjags_estimates_table(fit1, remove_spike_0 = FALSE, transform_factors = TRUE)), prior_weights = 1) ) models <- models_inference(models) @@ -1119,6 +1142,322 @@ test_that("Summary tables functions work (spike factors)",{ expect_equal(unname(as.vector(diagnostics_table[,2])), c("mean difference contrast: mSpike(0)", "mean difference contrast: mNormal(0, 0.25)")) expect_equal(unname(as.vector(diagnostics_table[,3])), c(0.0004365069, 0.0006020573), tolerance = 1e-3) expect_equal(unname(as.vector(diagnostics_table[,4])), c(0.01, 0.01), tolerance = 1e-3) - expect_equal(unname(as.vector(diagnostics_table[,5])), c(9774, 10554)) + expect_equal(unname(as.vector(diagnostics_table[,5])), c(0, 10554), tolerance = 1e-3) + +}) + +test_that("Summary tables functions work (mixture priors)",{ + + skip_on_os(c("mac", "linux", "solaris")) # multivariate sampling does not exactly match across OSes + skip_on_cran() + + set.seed(1) + + data_formula <- data.frame( + x_cont1 = rnorm(300), + x_fac2t = factor(rep(c("A", "B"), 150), levels = c("A", "B")), + x_fac3t = factor(rep(c("A", "B", "C"), 100), levels = c("A", "B", "C")) + ) + data <- list( + y = rnorm(300, -0.15 + 0.20 * data_formula$x_cont1 + ifelse(data_formula$x_fac3t == "A", 0.0, ifelse(data_formula$x_fac3t == "B", -0.2, 0.2)), ifelse(data_formula$x_fac2t == "A", 0.5, 1)), + N = 300 + ) + + # create model with mix of a formula and free parameters --- + formula_list1 <- list( + mu = ~ x_cont1 + x_fac3t + ) + formula_data_list1 <- list( + mu = data_formula + ) + formula_prior_list1 <- list( + mu = list( + "intercept" = prior_mixture( + list( + prior("spike", list(0), prior_weights = 2), + prior("normal", list(-1, 0.5), prior_weights = 1), + prior("normal", list( 1, 0.5), prior_weights = 1) + ), + is_null = c(T, F, F) + ), + "x_cont1" = prior_mixture( + list( + prior("spike", list(0), prior_weights = 1), + prior("normal", list(0, 1), prior_weights = 1) + ), + is_null = c(T, F) + ), + "x_fac3t" = prior_spike_and_slab(prior_factor("mnormal", list(0, 1), contrast = "orthonormal"), + prior_inclusion = prior("spike", list(0.5))) + ) + ) + attr(formula_prior_list1$mu$x_cont1, "multiply_by") <- "sigma" + prior_list1 <- list( + "sigma" = prior_mixture( + list( + prior("normal", list(0, 1), truncation = list(0, Inf)), + prior("lognormal", list(0, 1)) + ), + components = c("normal", "lognormal") + ), + "bias" = prior_mixture(list( + prior_none(prior_weights = 1), + prior_weightfunction(distribution = "two.sided", parameters = list(alpha = c(1, 1), steps = c(0.05)), prior_weights = 1/3), + prior_weightfunction(distribution = "one.sided", parameters = list(alpha = c(1, 1, 1), steps = c(0.025, 0.05)), prior_weights = 1/3), + prior_PET("normal", list(0, 1), prior_weights = 1/3) + ), is_null = c(T, F, F, F)) + ) + model_syntax1 <- paste0( + "model{\n", + "for(i in 1:N){\n", + " y[i] ~ dnorm(mu[i], 1/pow(sigma, 2))\n", + "}\n", + "}" + ) + + if("RoBMA" %in% rownames(installed.packages())){ + require("RoBMA") + }else{ + skip() + } + + fit1 <- JAGS_fit( + model_syntax = model_syntax1, data = data, prior_list = prior_list1, + formula_list = formula_list1, formula_data_list = formula_data_list1, formula_prior_list = formula_prior_list1) + + # bridge sampling cannot be computer for spike and slab priors - using a dummy value for marglik + marglik1 <- list(logml = 0) + class(marglik1) <- "bridge" + + # mix posteriors + models <- list( + list(fit = fit1, marglik = marglik1, fit_summary = runjags_estimates_table(fit1), prior_weights = 1) + ) + models <- models_inference(models) + + ### checking summary functions + # model summary + model_summary <- model_summary_table(models[[1]], short_name = TRUE) + expect_equal(model_summary[,1], c("Model ", "Prior prob. ", "log(marglik) ", "Post. prob. ", "Inclusion BF ", " ")) + expect_equal(model_summary[,4], c( + "Parameter prior distributions", + "(mu) intercept ~ (2/4) * S(0) + (1/4) * N(-1, 0.5) + (1/4) * N(1, 0.5)", + "(mu) x_cont1 ~ (1/2) * S(0) + (1/2) * N(0, 1)", + "(mu) x_fac3t ~ orthonormal contrast: mN(0, 1) * S(0.5)", + "sigma ~ (1/2) * N(0, 1)[0, Inf] + (1/2) * Ln(0, 1)", + "bias ~ (1/2) * None + (0.33/2) * omega[2s: .05] ~ CumD(1, 1) + (0.33/2) * omega[1s: .05, .025] ~ CumD(1, 1, 1) + (0.33/2) * PET ~ N(0, 1)[0, Inf]" + )) + + model_estimates <- runjags_estimates_table(fit1) + expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI error(MCMC) error(MCMC)/SD ESS R-hat", + "(mu) intercept (inclusion) 0.596 NA NA NA NA NA NA NA NA", + "(mu) intercept -0.087 0.080 -0.226 -0.098 0.000 0.00246 0.031 1067 1.002", + "(mu) x_cont1 (inclusion) 0.999 NA NA NA NA NA NA NA NA", + "(mu) x_cont1 0.279 0.063 0.154 0.280 0.401 0.00063 0.010 11015 1.000", + "(mu) x_fac3t (inclusion) 0.855 NA NA NA NA NA NA NA NA", + "(mu) x_fac3t[1] 0.252 0.128 0.000 0.277 0.448 0.00467 0.037 939 1.016", + "(mu) x_fac3t[2] -0.012 0.074 -0.167 0.000 0.137 0.00057 0.008 17039 1.001", + "sigma (inclusion: normal) 0.510 NA NA NA NA NA NA NA NA", + "sigma (inclusion: lognormal) 0.490 NA NA NA NA NA NA NA NA", + "sigma 0.803 0.034 0.740 0.802 0.874 0.00039 0.011 7753 1.000", + "bias (inclusion) 0.497 NA NA NA NA NA NA NA NA", + "PET 0.130 0.377 0.000 0.000 1.410 0.00292 0.008 16826 1.000", + "omega[0,0.025] 1.000 0.000 1.000 1.000 1.000 NA NA NA NA", + "omega[0.025,0.05] 0.865 0.248 0.139 1.000 1.000 0.00196 0.008 16000 1.000", + "omega[0.05,0.975] 0.809 0.316 0.053 1.000 1.000 0.00247 0.008 16361 1.000", + "omega[0.975,1] 0.889 0.267 0.076 1.000 1.000 0.00211 0.008 16128 1.000" + )) + + model_estimates <- suppressMessages(runjags_estimates_table(fit1, transform_factors = TRUE, conditional = TRUE)) + expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI", + "(mu) intercept (inclusion) 0.596 NA NA NA NA", + "(mu) intercept -0.145 0.047 -0.238 -0.146 -0.052", + "(mu) x_cont1 (inclusion) 0.999 NA NA NA NA", + "(mu) x_cont1 0.279 0.062 0.155 0.280 0.401", + "(mu) x_fac3t (inclusion) 0.855 NA NA NA NA", + "(mu) x_fac3t [dif: A] -0.012 0.066 -0.141 -0.012 0.116", + "(mu) x_fac3t [dif: B] -0.203 0.066 -0.333 -0.202 -0.074", + "(mu) x_fac3t [dif: C] 0.214 0.065 0.088 0.214 0.341", + "sigma (inclusion: normal) 0.510 NA NA NA NA", + "sigma (inclusion: lognormal) 0.490 NA NA NA NA", + "sigma[normal] 0.804 0.034 0.740 0.802 0.872", + "sigma[lognormal] 0.803 0.034 0.740 0.802 0.875", + "bias (inclusion) 0.497 NA NA NA NA", + "PET 0.780 0.589 0.031 0.656 2.113", + "omega[0,0.025] 1.000 0.000 1.000 1.000 1.000", + "omega[0.025,0.05] 0.592 0.275 0.048 0.627 0.984", + "omega[0.05,0.975] 0.421 0.279 0.017 0.386 0.953", + "omega[0.975,1] 0.663 0.374 0.027 0.916 1.000" + )) + + model_estimates <- runjags_estimates_table(fit1, transform_factors = TRUE, conditional = TRUE, remove_inclusion = TRUE) + expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI", + "(mu) intercept -0.145 0.047 -0.238 -0.146 -0.052", + "(mu) x_cont1 0.279 0.062 0.155 0.280 0.401", + "(mu) x_fac3t [dif: A] -0.012 0.066 -0.141 -0.012 0.116", + "(mu) x_fac3t [dif: B] -0.203 0.066 -0.333 -0.202 -0.074", + "(mu) x_fac3t [dif: C] 0.214 0.065 0.088 0.214 0.341", + "sigma[normal] 0.804 0.034 0.740 0.802 0.872", + "sigma[lognormal] 0.803 0.034 0.740 0.802 0.875", + "PET 0.780 0.589 0.031 0.656 2.113", + "omega[0,0.025] 1.000 0.000 1.000 1.000 1.000", + "omega[0.025,0.05] 0.592 0.275 0.048 0.627 0.984", + "omega[0.05,0.975] 0.421 0.279 0.017 0.386 0.953", + "omega[0.975,1] 0.663 0.374 0.027 0.916 1.000" + )) + + model_estimates <- runjags_estimates_table(fit1, transformations = list( + "mu_intercept" = list(fun = exp), + "mu_x_cont1" = list(fun = exp), + "sigma" = list(fun = exp), + "PET" = list(fun = exp) + )) + expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI error(MCMC) error(MCMC)/SD ESS R-hat", + "(mu) intercept (inclusion) 0.596 NA NA NA NA NA NA NA NA", + "(mu) intercept 0.920 0.073 0.798 0.907 1.000 0.00225 0.031 1061 1.002", + "(mu) x_cont1 (inclusion) 0.999 NA NA NA NA NA NA NA NA", + "(mu) x_cont1 1.324 0.083 1.166 1.323 1.494 0.00081 0.010 11242 1.000", + "(mu) x_fac3t (inclusion) 0.855 NA NA NA NA NA NA NA NA", + "(mu) x_fac3t[1] 0.252 0.128 0.000 0.277 0.448 0.00467 0.037 939 1.016", + "(mu) x_fac3t[2] -0.012 0.074 -0.167 0.000 0.137 0.00057 0.008 17039 1.001", + "sigma (inclusion: normal) 0.510 NA NA NA NA NA NA NA NA", + "sigma (inclusion: lognormal) 0.490 NA NA NA NA NA NA NA NA", + "sigma 2.235 0.077 2.097 2.231 2.395 0.00088 0.011 7722 1.000", + "bias (inclusion) 0.497 NA NA NA NA NA NA NA NA", + "PET 1.288 1.525 1.000 1.000 4.095 0.01205 0.008 16030 1.093", + "omega[0,0.025] 1.000 0.000 1.000 1.000 1.000 NA NA NA NA", + "omega[0.025,0.05] 0.865 0.248 0.139 1.000 1.000 0.00196 0.008 16000 1.000", + "omega[0.05,0.975] 0.809 0.316 0.053 1.000 1.000 0.00247 0.008 16361 1.000", + "omega[0.975,1] 0.889 0.267 0.076 1.000 1.000 0.00211 0.008 16128 1.000" + )) + + model_estimates <- runjags_estimates_table(fit1, conditional = TRUE, remove_inclusion = TRUE, transformations = list( + "mu_intercept" = list(fun = exp), + "mu_x_cont1" = list(fun = exp), + "sigma" = list(fun = exp), + "PET" = list(fun = exp) + )) + expect_equal(capture_output_lines(print(model_estimates), width = 150), c( + " Mean SD lCI Median uCI", + "(mu) intercept 0.866 0.041 0.788 0.864 0.949", + "(mu) x_cont1 1.325 0.083 1.168 1.323 1.494", + "(mu) x_fac3t[1] 0.295 0.081 0.138 0.295 0.454", + "(mu) x_fac3t[2] -0.014 0.080 -0.173 -0.015 0.142", + "sigma[normal] 2.235 0.077 2.097 2.231 2.392", + "sigma[lognormal] 2.234 0.077 2.097 2.231 2.400", + "PET 2.726 3.384 1.032 1.927 8.272", + "omega[0,0.025] 1.000 0.000 1.000 1.000 1.000", + "omega[0.025,0.05] 0.592 0.275 0.048 0.627 0.984", + "omega[0.05,0.975] 0.421 0.279 0.017 0.386 0.953", + "omega[0.975,1] 0.663 0.374 0.027 0.916 1.000" + )) + + model_inference <- runjags_inference_table(fit1) + expect_equal(capture_output_lines(print(model_inference), width = 150), c( + " Prior prob. Post. prob. Inclusion BF", + "(mu) intercept 0.500 0.596 1.478", + "(mu) x_cont1 0.500 0.999 841.105", + "(mu) x_fac3t 0.500 0.855 5.894", + "sigma [normal] 0.500 0.510 1.041", + "sigma [lognormal] 0.500 0.490 0.961", + "bias 0.500 0.497 0.989" + )) + + model_inference <- update(model_inference, title = "Table 1", footnotes = c("Footnote 1", "Footnote 2"), logBF = TRUE) + expect_equal(capture_output_lines(print(model_inference), width = 150), c( + "Table 1" , + " Prior prob. Post. prob. log(Inclusion BF)", + "(mu) intercept 0.500 0.596 0.391", + "(mu) x_cont1 0.500 0.999 6.735", + "(mu) x_fac3t 0.500 0.855 1.774", + "sigma [normal] 0.500 0.510 0.040", + "sigma [lognormal] 0.500 0.490 -0.040", + "bias 0.500 0.497 -0.011", + "Footnote 1" , + "Footnote 2" )) +}) + +test_that("Summary tables odd cases",{ + + set.seed(1) + + data <- list( + y = rnorm(10), + N = 10 + ) + + prior_list <- list( + "mu" = prior_mixture( + list(prior("spike", list(0))), + is_null = c(FALSE) + ), + "sigma" = prior_mixture( + list(prior("spike", list(1))), + is_null = c(TRUE) + ), + "beta" = prior("normal", list(0, 1)) + ) + model_syntax <- paste0( + "model{\n", + "for(i in 1:N){\n", + " y[i] ~ dnorm(mu, 1/pow(sigma, 2))\n", + "}\n", + "}" + ) + + fit <- JAGS_fit( + model_syntax = model_syntax, data = data, prior_list = prior_list + ) + + expect_equal(capture_output_lines(print(runjags_estimates_table(fit)), width = 150), c( + " Mean SD lCI Median uCI error(MCMC) error(MCMC)/SD ESS R-hat", + "mu (inclusion) 1.000 NA NA NA NA NA NA NA NA", + "mu 0.000 0.000 0.000 0.000 0.000 0.00000 NA 0 NA", + "sigma (inclusion) 0.000 NA NA NA NA NA NA NA NA", + "sigma 1.000 0.000 1.000 1.000 1.000 0.00000 NA 0 NA", + "beta -0.014 0.999 -1.985 -0.003 1.930 0.00805 0.008 15412 1.000" + )) + + expect_equal(capture_output_lines(print(runjags_estimates_table(fit, conditional = TRUE)), width = 150), c( + " Mean SD lCI Median uCI", + "mu (inclusion) 1.000 NA NA NA NA", + "mu 0.000 0.000 0.000 0.000 0.000", + "sigma (inclusion) 0.000 NA NA NA NA", + "sigma NaN NA NA NA NA", + "beta -0.014 0.999 -1.985 -0.003 1.930", + "\033[0;31mConditional summary for sigma parameter could not be computed due to no posterior samples.\033[0m" + )) + + expect_equal(capture_output_lines(print(runjags_inference_table(fit)), width = 150), c( + " Prior prob. Post. prob. Inclusion BF", + "mu 1.000 1.000 Inf", + "sigma 0.000 0.000 0.000" + )) + +}) + +test_that("Simplified interpret2 function", { + + set.seed(1) + information <- list( + list( + inference_name = "Effect", + inference_BF_name = "BF10", + inference_BF = 3.5, + estimate_name = "mu", + estimate_samples = rnorm(1000, 0.3, 0.15), + estimate_units = "kg", + estimate_conditional = FALSE + ) + ) + + expect_equal( + interpret2(information, "RoBMA"), + "RoBMA found moderate evidence in favor of the Effect, BF10 = 3.50, with mean model-averaged estimate mu = 0.298 kg, 95% CI [-0.020, 0.601]." + ) })