├── .Rbuildignore ├── .github ├── .gitignore └── workflows │ ├── R-CMD-check.yaml │ └── pkgdown.yaml ├── .gitignore ├── CITATION.cff ├── CONTRIBUTING.md ├── DESCRIPTION ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── additional_divergence_measures.R ├── brms-functions.R ├── cjs.R ├── create_priorsense_data.R ├── cumulative_plot.R ├── ewcdf.R ├── example_powerscale_model.R ├── find_alpha_threshold.R ├── get_draws.R ├── ggplot_theme.R ├── helpers.R ├── log_lik_draws.R ├── log_prior_draws.R ├── measure_divergence.R ├── plots.R ├── powerscale.R ├── powerscale_derivative.R ├── powerscale_gradients.R ├── powerscale_sensitivity.R ├── powerscale_sequence.R ├── print.R ├── priorsense-package.R ├── scale_draws.R ├── scaled_log_ratio.R ├── srr-stats-standards.R ├── summarise_draws.R ├── sysdata.rda ├── weighted_diagnostics.R ├── weighted_quantities.R └── whiten_draws.R ├── README.md ├── README.qmd ├── _pkgdown.yml ├── codemeta.json ├── cran-comments.md ├── inst ├── CITATION └── logo │ └── logo.R ├── man-roxygen ├── alpha_args.R ├── div_measure_arg.R ├── draws_and_weights_arg.R ├── fit_arg.R ├── ggplot_return.R ├── log_comp_name.R ├── log_lik_log_prior.R ├── plot_args.R ├── powerscale_args.R ├── powerscale_references.R ├── prediction_arg.R ├── resample_arg.R └── selection_arg.R ├── man ├── cjs_dist.Rd ├── create-priorsense-data.Rd ├── example_powerscale_model.Rd ├── figures │ ├── logo.png │ ├── powerscale-plot_dens-1.png │ ├── powerscale_plot_ecdf-1.png │ └── powerscale_plot_quantities-1.png ├── log_lik_draws.Rd ├── log_prior_draws.Rd ├── powerscale-gradients.Rd ├── powerscale-overview.Rd ├── powerscale-sensitivity.Rd ├── powerscale_derivative.Rd ├── powerscale_plots.Rd ├── predictions_as_draws.Rd └── priorsense-package.Rd ├── priorsense.Rproj ├── tests ├── testthat.R └── testthat │ ├── test_cjs.R │ ├── test_cmdstan.R │ ├── test_conjugate.R │ ├── test_deriv.R │ ├── test_div_measures.R │ ├── test_moment_matching.R │ ├── test_plots.R │ ├── test_powerscale.R │ ├── test_print.R │ ├── test_resample.R │ ├── test_rstan.R │ ├── test_scale_draws.R │ ├── test_weighted.R │ └── test_whiten_draws.R └── vignettes ├── .gitignore ├── powerscaling.qmd ├── priorsense_with_jags.qmd ├── quantity_of_interest.qmd ├── selecting_priors_and_quantities.qmd └── sensitivity_diagnostic.qmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^renv$ 2 | ^renv\.lock$ 3 | ^priorsense\.Rproj$ 4 | ^\.Rproj\.user$ 5 | ^LICENSE\.md$ 6 | ^README\.Rmd$ 7 | ^README\.qmd$ 8 | ^README\.html$ 9 | ^cran-comments\.md$ 10 | ^\.github$ 11 | ^man-roxygen$ 12 | ^_pkgdown\.yml$ 13 | ^docs$ 14 | ^pkgdown$ 15 | ^README_files$ 16 | ^codecov\.yml$ 17 | ^doc$ 18 | ^Meta$ 19 | ^CRAN-SUBMISSION$ 20 | ^codemeta\.json$ 21 | ^CONTRIBUTING\.md$ 22 | ^CITATION\.cff$ 23 | ^vignettes/articles/\.quarto$ 24 | ^vignettes/articles/*_files$ 25 | ^vignettes/articles$ 26 | ^vignettes/selecting_priors_and_quantities.qmd$ 27 | ^vignettes/quantity_of_interest.qmd$ 28 | ^vignettes/sensitivity_diagnostic.qmd$ 29 | ^vignettes/selecting_priors_and_quantities_files$ 30 | ^vignettes/quantity_of_interest_files$ 31 | ^vignettes/sensitivity_diagnostic_files$ 32 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/master/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, development] 6 | pull_request: 7 | branches: [main, development] 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | #- {os: macOS-latest, r: 'devel', rtools: ''} 22 | #- {os: macOS-latest, r: 'release', rtools: ''} 23 | #- {os: windows-latest, r: 'devel', rtools: '45'} 24 | #- {os: windows-latest, r: 'release', rtools: '45'} 25 | - {os: ubuntu-22.04, r: 'devel', rtools: ''} 26 | - {os: ubuntu-22.04, r: 'release', rtools: ''} 27 | 28 | env: 29 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 30 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 31 | R_KEEP_PKG_SOURCE: yes 32 | NOT_CRAN: true 33 | 34 | steps: 35 | - name: cmdstan env vars 36 | run: | 37 | echo "CMDSTAN_PATH=${HOME}/.cmdstan" >> $GITHUB_ENV 38 | shell: bash 39 | - uses: n1hility/cancel-previous-runs@v3 40 | with: 41 | token: ${{ secrets.GITHUB_TOKEN }} 42 | 43 | - uses: actions/checkout@v4 44 | 45 | - uses: r-lib/actions/setup-r@v2 46 | with: 47 | r-version: ${{ matrix.config.r }} 48 | rtools-version: ${{ matrix.config.rtools }} 49 | use-public-rspm: true 50 | - uses: r-lib/actions/setup-pandoc@v2 51 | with: 52 | pandoc-version: 'latest' 53 | 54 | # packages that are needed for R CMD CHECK 55 | - uses: r-lib/actions/setup-r-dependencies@v2 56 | with: 57 | cache-version: 3 58 | extra-packages: | 59 | XML 60 | stan-dev/cmdstanr 61 | topipa/iwmm 62 | rcmdcheck 63 | rstan 64 | checkmate 65 | jsonlite 66 | posterior 67 | processx 68 | R6 69 | BH 70 | RcppEigen 71 | StanHeaders 72 | RcppParallel 73 | R2jags 74 | withr 75 | testthat 76 | quarto 77 | any::XML 78 | any::textshaping 79 | 80 | - name: Install cmdstan 81 | run: | 82 | cmdstanr::check_cmdstan_toolchain(fix = TRUE) 83 | cmdstanr::install_cmdstan(cores = 2) 84 | shell: Rscript {0} 85 | 86 | - uses: r-lib/actions/check-r-package@v2 87 | with: 88 | args: 'c("--no-manual", "--as-cran")' 89 | error-on: '"warning"' 90 | check-dir: '"check"' 91 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | pkgdown: 18 | runs-on: ubuntu-latest 19 | # Only restrict concurrency for non-PR jobs 20 | concurrency: 21 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 22 | env: 23 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 24 | permissions: 25 | contents: write 26 | steps: 27 | - uses: actions/checkout@v4 28 | 29 | - uses: r-lib/actions/setup-pandoc@v2 30 | 31 | - uses: quarto-dev/quarto-actions/setup@v2 32 | 33 | - uses: r-lib/actions/setup-r@v2 34 | with: 35 | use-public-rspm: true 36 | 37 | - uses: r-lib/actions/setup-r-dependencies@v2 38 | with: 39 | extra-packages: | 40 | any::pkgdown 41 | local::. 42 | XML 43 | stan-dev/cmdstanr 44 | paul-buerkner/brms 45 | topipa/iwmm 46 | rcmdcheck 47 | rstan 48 | checkmate 49 | jsonlite 50 | posterior 51 | processx 52 | R6 53 | BH 54 | R2jags 55 | RcppEigen 56 | StanHeaders 57 | RcppParallel 58 | withr 59 | testthat 60 | quarto 61 | any::XML 62 | any::textshaping 63 | needs: website 64 | 65 | - name: Build site 66 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = TRUE) 67 | shell: Rscript {0} 68 | 69 | - name: Deploy to GitHub pages 🚀 70 | if: github.event_name != 'pull_request' 71 | uses: JamesIves/github-pages-deploy-action@v4.6.8 72 | with: 73 | clean: false 74 | branch: gh-pages 75 | folder: docs 76 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | inst/doc 3 | .Rproj.user 4 | .Rhistory 5 | .Rdata 6 | priorsense.Rcheck 7 | .httr-oauth 8 | .DS_Store 9 | docs 10 | /doc/ 11 | /Meta/ 12 | /pkgdown/ 13 | /..Rcheck/ 14 | README.html 15 | **/.quarto/ 16 | -------------------------------------------------------------------------------- /CITATION.cff: -------------------------------------------------------------------------------- 1 | cff-version: "1.2.0" 2 | message: If you use this software, please cite our article in Statistics and Computing. 3 | preferred-citation: 4 | type: article 5 | authors: 6 | - family-names: Kallioinen 7 | given-names: Noa 8 | orcid: "https://orcid.org/0000-0003-1586-8382" 9 | - family-names: Paananen 10 | given-names: Topi 11 | orcid: "https://orcid.org/0000-0002-6542-407X" 12 | - family-names: Bürkner 13 | given-names: Paul-Christian 14 | orcid: "https://orcid.org/0000-0001-5765-8995" 15 | - family-names: Vehtari 16 | given-names: Aki 17 | orcid: "https://orcid.org/0000-0003-2164-9469" 18 | year: 2023 19 | doi: 10.1007/s11222-023-10366-5 20 | pages: 57 21 | journal: Statistics and Computing 22 | publisher: 23 | name: Springer Nature 24 | volume: 34 25 | title: "Detecting and diagnosing prior and likelihood sensitivity with power-scaling" 26 | url: "https://link.springer.com/article/10.1007/s11222-023-10366-5" 27 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | Contributions are welcome! If you find an bug or have an idea for a feature, open an issue. If you are able to fix an issue, fork the repository and make a pull request to the `development` branch. 4 | 5 | ## Lifecycle 6 | priorsense is in a stable state of development, with some degree of active subsequent development as envisioned by the primary authors and in response to user feedback. 7 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: priorsense 2 | Title: Prior Diagnostics and Sensitivity Analysis 3 | Version: 1.1.1.9000 4 | Authors@R: c(person("Noa", "Kallioinen", email = "noa.kallioinen@aalto.fi", role = c("aut", "cre", "cph")), 5 | person("Topi", "Paananen", role = c("aut")), 6 | person("Paul-Christian", "Bürkner", role = c("aut")), 7 | person("Aki", "Vehtari", role = c("aut")), 8 | person("Frank", "Weber", role = c("ctb")) 9 | ) 10 | Description: Provides functions for prior and likelihood sensitivity analysis in Bayesian models. Currently it implements methods to determine the sensitivity of the posterior to power-scaling perturbations of the prior and likelihood. 11 | License: GPL (>= 3) 12 | Encoding: UTF-8 13 | LazyData: true 14 | Roxygen: list(markdown = TRUE, roclets = c ("namespace", "rd", "srr::srr_stats_roclet")) 15 | RoxygenNote: 7.3.2 16 | Imports: 17 | checkmate (>= 2.3.1), 18 | ggdist (>= 3.3.2), 19 | ggh4x (>= 0.2.5), 20 | ggplot2 (>= 3.5.1), 21 | grDevices (>= 3.6.2), 22 | matrixStats (>= 1.3.0), 23 | posterior (>= 1.6.0), 24 | rlang (>= 1.1.4), 25 | stats, 26 | tibble (>= 3.2.1), 27 | utils 28 | Suggests: 29 | bayesplot (>= 1.11.1), 30 | brms (>= 2.22.0), 31 | cmdstanr (>= 0.8.1), 32 | iwmm (>= 0.0.1), 33 | philentropy (>= 0.8.0), 34 | quarto (>= 1.4.4), 35 | R2jags (>= 0.8), 36 | rstan (>= 2.32.6), 37 | testthat (>= 3.0.0), 38 | transport (>= 0.15), 39 | vdiffr (>= 1.0.8) 40 | Config/testthat/edition: 3 41 | Depends: 42 | R (>= 3.6.0) 43 | VignetteBuilder: quarto 44 | Additional_repositories: 45 | https://topipa.r-universe.dev, 46 | https://stan-dev.r-universe.dev 47 | URL: https://github.com/n-kall/priorsense, https://n-kall.github.io/priorsense/ 48 | BugReports: https://github.com/n-kall/priorsense/issues 49 | Config/Needs/website: quarto 50 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(create_priorsense_data,CmdStanFit) 4 | S3method(create_priorsense_data,default) 5 | S3method(create_priorsense_data,draws) 6 | S3method(create_priorsense_data,rjags) 7 | S3method(create_priorsense_data,stanfit) 8 | S3method(find_alpha_threshold,default) 9 | S3method(find_alpha_threshold,priorsense_data) 10 | S3method(log_lik_draws,CmdStanFit) 11 | S3method(log_lik_draws,draws) 12 | S3method(log_lik_draws,stanfit) 13 | S3method(log_prior_draws,CmdStanFit) 14 | S3method(log_prior_draws,draws) 15 | S3method(log_prior_draws,stanfit) 16 | S3method(plot,priorsense_plot) 17 | S3method(posterior::summarise_draws,powerscaled_draws) 18 | S3method(posterior::summarise_draws,powerscaled_sequence) 19 | S3method(powerscale,default) 20 | S3method(powerscale,priorsense_data) 21 | S3method(powerscale_gradients,default) 22 | S3method(powerscale_gradients,priorsense_data) 23 | S3method(powerscale_plot_dens,default) 24 | S3method(powerscale_plot_dens,powerscaled_sequence) 25 | S3method(powerscale_plot_ecdf,default) 26 | S3method(powerscale_plot_ecdf,powerscaled_sequence) 27 | S3method(powerscale_plot_quantities,default) 28 | S3method(powerscale_plot_quantities,powerscaled_sequence) 29 | S3method(powerscale_sensitivity,CmdStanFit) 30 | S3method(powerscale_sensitivity,default) 31 | S3method(powerscale_sensitivity,priorsense_data) 32 | S3method(powerscale_sensitivity,stanfit) 33 | S3method(powerscale_sequence,default) 34 | S3method(powerscale_sequence,priorsense_data) 35 | S3method(print,powerscaled_draws) 36 | S3method(print,powerscaled_draws_summary) 37 | S3method(print,powerscaled_sensitivity_summary) 38 | S3method(print,powerscaled_sequence) 39 | S3method(print,powerscaling_details) 40 | S3method(print,priorsense_plot) 41 | S3method(print,whitened_draws) 42 | S3method(print,whitened_draws_summary) 43 | S3method(summarise_draws,whitened_draws) 44 | export(cjs_dist) 45 | export(create_priorsense_data) 46 | export(example_powerscale_model) 47 | export(log_lik_draws) 48 | export(log_prior_draws) 49 | export(powerscale) 50 | export(powerscale_derivative) 51 | export(powerscale_gradients) 52 | export(powerscale_plot_dens) 53 | export(powerscale_plot_ecdf) 54 | export(powerscale_plot_quantities) 55 | export(powerscale_sensitivity) 56 | export(powerscale_sequence) 57 | export(predictions_as_draws) 58 | importFrom(posterior,summarise_draws) 59 | importFrom(rlang,.data) 60 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | priorsense 1.1.1.9000 2 | --- 3 | 4 | 5 | priorsense 1.1.0 6 | --- 7 | + Add pagination of plots when there are many variables 8 | + Selection of priors updated to work with brms prior tags 9 | + Fix issue with component argument in powerscale_sensitivity 10 | + Fix MCSE not displaying in powerscale_plot_quantities 11 | + Switch to quarto for vignettes 12 | + Add support for rjags objects from R2jags 13 | 14 | priorsense 1.0.4 15 | --- 16 | + Fix an issue where `lower_alpha` was not taken into account when 17 | calculating the gradient of the divergence. 18 | 19 | priorsense 1.0.3 20 | --- 21 | + Fix issue with model parameter named "alpha" 22 | 23 | priorsense 1.0.2 24 | --- 25 | + Fix to Pareto smoothing of weights 26 | + Improvements to vignette 27 | 28 | priorsense 1.0.1 29 | --- 30 | + Fixes to documentation and description 31 | 32 | priorsense 1.0.0 33 | --- 34 | + First stable release 35 | -------------------------------------------------------------------------------- /R/brms-functions.R: -------------------------------------------------------------------------------- 1 | ##' brms predictions as draws 2 | ##' 3 | ##' Create predictions using brms functions and convert them into 4 | ##' draws format 5 | ##' 6 | ##' @param x brmsfit object 7 | ##' @param predict_fn function for predictions 8 | ##' @param prediction_names optional names of the predictions 9 | ##' @param warn_dims throw a warning when coercing predict_fn's output from 3 10 | ##' margins to 2 margins? 11 | ##' @param ... further arguments passed to predict_fn 12 | ##' @return draws array of predictions 13 | ##' @examples 14 | ##' \dontrun{ 15 | ##' library(brms) 16 | ##' 17 | ##' if ("log_prior_draws.brmsfit" %in% methods(log_prior_draws) && 18 | ##' ("log_lik_draws.brmsfit" %in% methods(log_lik_draws))) { 19 | ##' fit <- brm( 20 | ##' yield ~ N * P * K, 21 | ##' data = npk, 22 | ##' prior = prior(normal(0, 1), class = "b"), 23 | ##' refresh = 0 24 | ##' ) 25 | ##' 26 | ##' powerscale_sensitivity( 27 | ##' fit, 28 | ##' variable = "_pred", 29 | ##' prediction = function(x) predictions_as_draws( 30 | ##' x, brms::posterior_epred 31 | ##' ) 32 | ##' ) 33 | ##' } 34 | ##' } 35 | ##' @export 36 | predictions_as_draws <- function(x, predict_fn, prediction_names = NULL, 37 | warn_dims = getOption("priorsense.warn", TRUE), 38 | ...) { 39 | require_package("brms") 40 | terms <- brms::brmsterms(x$formula) 41 | if(inherits(terms, "mvbrmsterms")) { 42 | responses <- brms::brmsterms(x$formula)$responses 43 | mv <- TRUE 44 | } else { 45 | responses <- "" 46 | mv <- FALSE 47 | } 48 | pred_draws <- list() 49 | predictions <- predict_fn(x, ...) 50 | if (!(mv)) { 51 | dim_pred <- dim(predictions) 52 | if (length(dim_pred) == 3) { 53 | if (warn_dims) { 54 | warning("coercing predict_fn()'s output from 3 margins to 2 margins ", 55 | "(by making the former margin 2 nested within blocks which ", 56 | "correspond to former margin 3)") 57 | } 58 | predictions <- array(predictions, 59 | dim = c(dim_pred[1], dim_pred[2] * dim_pred[3])) 60 | } else if (length(dim_pred) > 3) { 61 | stop("predict_fn() returned an unexpected number of margins (> 3) for ", 62 | "this univariate model") 63 | } 64 | # add additional dimension in univariate case 65 | dim(predictions) <- c(dim(predictions), 1) 66 | } else { 67 | if (length(dim_pred) != 3) { 68 | stop("predict_fn() returned an unexpected number of margins (!= 3) for ", 69 | "this multivariate model") 70 | } 71 | } 72 | for (resp in seq_along(responses)) { 73 | # create draws array of predictions for each response variable 74 | predicted_draws <- posterior::as_draws_array( 75 | array( 76 | predictions[, , resp], 77 | dim = c( 78 | posterior::ndraws(x) / posterior::nchains(x), 79 | posterior::nchains(x), dim(predictions)[2] 80 | ) 81 | ) 82 | ) 83 | # name predicted variables 84 | posterior::variables(predicted_draws) <- c( 85 | paste0( 86 | responses[[resp]], 87 | "_pred[", 88 | seq_along(posterior::variables(predicted_draws)), 89 | "]") 90 | ) 91 | pred_draws[[resp]] <- predicted_draws 92 | } 93 | # bind draws from different responses 94 | out <- posterior::bind_draws(pred_draws) 95 | if (!(is.null(prediction_names))) { 96 | posterior::variables(out) <- prediction_names 97 | } 98 | out 99 | } 100 | -------------------------------------------------------------------------------- /R/cjs.R: -------------------------------------------------------------------------------- 1 | ##' Cumulative Jensen-Shannon divergence 2 | ##' 3 | ##' Computes the cumulative Jensen-Shannon distance between two 4 | ##' samples. 5 | ##' 6 | ##' The Cumulative Jensen-Shannon distance is a symmetric metric based 7 | ##' on the cumulative Jensen-Shannon divergence. The divergence CJS(P || Q) 8 | ##' between two cumulative distribution functions P and Q is defined as: 9 | ##' 10 | ##' \deqn{CJS(P || Q) = \sum P(x) \log \frac{P(x)}{0.5 (P(x) + Q(x))} + 11 | ##' \frac{1}{2 \ln 2} \sum (Q(x) - P(x))} 12 | ##' 13 | ##' The symmetric metric is defined as: 14 | ##' 15 | ##' \deqn{CJS_{dist}(P || Q) = \sqrt{CJS(P || Q) + CJS(Q || P)}} 16 | ##' 17 | ##' This has an upper bound of \eqn{\sqrt{ \sum (P(x) + Q(x))}} 18 | ##' 19 | ##' @template draws_and_weights_arg 20 | ##' @param metric Logical; if TRUE, return square-root of CJS. Default 21 | ##' is TRUE 22 | ##' @param unsigned Logical; if TRUE then return max of CJS(P(x) || 23 | ##' Q(x)) and CJS(P(-x) || Q(-x)). This ensures invariance to 24 | ##' transformations such as PCA. Default is TRUE 25 | ##' @param ... unused 26 | ##' @return distance value based on CJS computation. 27 | ##' @references Nguyen H-V., Vreeken J. (2015). Non-parametric 28 | ##' Jensen-Shannon Divergence. In: Appice A., Rodrigues P., Santos 29 | ##' Costa V., Gama J., Jorge A., Soares C. (eds) Machine Learning 30 | ##' and Knowledge Discovery in Databases. ECML PKDD 2015. Lecture 31 | ##' Notes in Computer Science, vol 9285. Springer, Cham. 32 | ##' \code{doi:10.1007/978-3-319-23525-7_11} 33 | ##' @srrstats {G2.0a} Documentation specifies weights vector must be 34 | ##' same length as draws 35 | ##' @srrstats {G2.13} missing values not allowed and result in error 36 | ##' @srrstats {G2.16} Inf, -Inf and NaN result in error 37 | ##' @srrstats {G2.2} Input is checked that it is numeric vector and 38 | ##' excludes matrix 39 | ##' @srrstats {G2.6} x and y can be atomic vectors, but not matrix 40 | ##' @examples 41 | ##' x <- rnorm(100) 42 | ##' y <- rnorm(100, 2, 2) 43 | ##' cjs_dist(x, y, x_weights = NULL, y_weights = NULL) 44 | ##' @export 45 | cjs_dist <- function(x, 46 | y, 47 | x_weights = NULL, 48 | y_weights = NULL, 49 | metric = TRUE, 50 | unsigned = TRUE, 51 | ...) { 52 | 53 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE, finite = TRUE) 54 | checkmate::assert_atomic_vector(x) 55 | x <- as.numeric(x) 56 | 57 | checkmate::assert_numeric(y, min.len = 1, any.missing = FALSE, finite = TRUE) 58 | checkmate::assert_atomic_vector(y) 59 | y <- as.numeric(y) 60 | 61 | checkmate::assert_numeric(x_weights, len = length(x), null.ok = TRUE, 62 | any.missing = FALSE, finite = TRUE) 63 | checkmate::assert_numeric(y_weights, len = length(y), null.ok = TRUE, 64 | any.missing = FALSE, finite = TRUE) 65 | 66 | checkmate::assert_vector(x_weights, strict = TRUE, null.ok = TRUE) 67 | checkmate::assert_vector(y_weights, strict = TRUE, null.ok = TRUE) 68 | 69 | checkmate::assert_flag(metric) 70 | checkmate::assert_flag(unsigned) 71 | 72 | if ( 73 | all(is.na(x)) || 74 | all(is.na(y)) || 75 | (all(y_weights == 0) && !is.null(y_weights)) 76 | ) { 77 | cjs <- NA 78 | } else if (identical(x, y) && identical(x_weights, y_weights)) { 79 | cjs <- 0 80 | } else { 81 | cjs <- .cjs_dist(x, y, x_weights, y_weights, metric) 82 | if (unsigned) { 83 | cjsm <- .cjs_dist(-x, -y, x_weights, y_weights, metric) 84 | cjs <- max(cjs, cjsm) 85 | } 86 | } 87 | return(c(cjs = cjs)) 88 | } 89 | 90 | .cjs_dist <- function(x, y, x_weights, y_weights, metric, ...) { 91 | # sort draws and weights 92 | x_idx <- order(x) 93 | x <- x[x_idx] 94 | wp <- x_weights[x_idx] 95 | 96 | y_idx <- order(y) 97 | y <- y[y_idx] 98 | wq <- y_weights[y_idx] 99 | 100 | if (is.null(wp)) { 101 | wp <- rep(1 / length(x), length(x)) 102 | } 103 | if (is.null(wq)) { 104 | wq <- rep(1 / length(y), length(y)) 105 | } 106 | 107 | if (identical(x, y)) { 108 | # if all x and y are same, but y is a weighted version of x 109 | # calculate weighted ecdf via cumsum of weights and use natural 110 | # bins from stepfun 111 | bins <- x[-length(x)] 112 | binwidth <- diff(x) 113 | px <- cumsum(wp / sum(wp)) 114 | px <- px[-length(px)] 115 | qx <- cumsum(wq / sum(wq)) 116 | qx <- qx[-length(qx)] 117 | } else { 118 | # otherwise the draws are not the same (e.g. resampled) we use 119 | # approximation with bins and ewcdf. There is a slight bias in 120 | # this case which overestimates the cjs compared to weighted 121 | # version 122 | nbins <- max(length(x), length(y)) 123 | bins <- seq( 124 | from = min(min(x), min(y)), 125 | to = max(max(x), max(y)), 126 | length.out = nbins 127 | ) 128 | binwidth <- bins[2] - bins[1] 129 | 130 | # calculate required weighted ecdfs 131 | px <- ewcdf(x, wp)(bins) 132 | qx <- ewcdf(y, wq)(bins) 133 | } 134 | 135 | # calculate integral of ecdfs 136 | px_int <- sum(px * binwidth) 137 | qx_int <- sum(qx * binwidth) 138 | 139 | # calculate cjs 140 | cjs_pq <- sum(binwidth * ( 141 | px * (log(px, base = 2) - 142 | log(0.5 * px + 0.5 * qx, base = 2) 143 | )), na.rm = TRUE) + 0.5 / log(2) * (qx_int - px_int) 144 | 145 | cjs_qp <- sum(binwidth * ( 146 | qx * (log(qx, base = 2) - 147 | log(0.5 * qx + 0.5 * px, base = 2) 148 | )), na.rm = TRUE) + 0.5 / log(2) * (px_int - qx_int) 149 | 150 | # calculate upper bound 151 | bound <- px_int + qx_int 152 | 153 | # normalise with respect to upper bound 154 | out <- (cjs_pq + cjs_qp) / bound 155 | 156 | if (metric) { 157 | out <- sqrt(out) 158 | } 159 | return(out) 160 | } 161 | -------------------------------------------------------------------------------- /R/create_priorsense_data.R: -------------------------------------------------------------------------------- 1 | ##' Create data structure for priorsense 2 | ##' 3 | ##' Create a data structure that contains all required data and 4 | ##' functions for priorsense 5 | ##' @name create-priorsense-data 6 | ##' @param x an object for which the method is defined or an object 7 | ##' coercible to a `posterior::draws` object 8 | ##' @param fit a model fit object (only used if x is not a fit object) 9 | ##' @param log_prior_fn function to derive log prior from x or fit (if 10 | ##' not NULL) 11 | ##' @param log_lik_fn function to derive log likelihood from x or fit 12 | ##' (if not NULL) 13 | ##' @param log_prior draws object from log prior, must be numeric and 14 | ##' not include NA, NaN, Inf, -Inf or be constant 15 | ##' @param log_lik draws from log likelihood, must be numeric and not 16 | ##' include NA, NaN, Inf, -Inf or be constant 17 | ##' @param log_ratio_fn function for moment matching 18 | ##' @template log_comp_name 19 | ##' @param ... arguments passed to methods 20 | ##' @return A `priorsense_data` object, which contains the data and 21 | ##' functions to run sensitivity analyses. 22 | ##' @srrstats {G2.1, G2.1a} Assertions on inputs and documented types 23 | ##' @srrstats {G2.4} Input coercion 24 | ##' @srrstats {G2.4b} Input coercion with `as.numeric()` 25 | ##' @srrstats {G2.4c} Input coercion with `as.character()` 26 | ##' @srrstats {G2.4e} Input coercion 27 | ##' @srrstats {G2.7} x can be an object coercible to 28 | ##' `posterior::draws` object which includes many tabular formats 29 | ##' @srrstats {G2.8} the `priorsense_data` class is constructed to 30 | ##' contain all the required data for the primary functions in the 31 | ##' package 32 | 33 | ##' @examples 34 | ##' x <- example_powerscale_model() 35 | ##' drw <- x$draws 36 | ##' 37 | ##' psd <- create_priorsense_data(drw) 38 | ##' @export 39 | create_priorsense_data <- function(x, ...) { 40 | UseMethod("create_priorsense_data") 41 | } 42 | 43 | ##' @rdname create-priorsense-data 44 | ##' @export 45 | create_priorsense_data.default <- function(x, 46 | fit = NULL, 47 | log_prior_fn = log_prior_draws, 48 | log_lik_fn = log_lik_draws, 49 | log_prior = NULL, 50 | log_lik = NULL, 51 | log_ratio_fn = NULL, 52 | log_prior_name = "lprior", 53 | log_lik_name = "log_lik", 54 | ...) { 55 | 56 | # input coercion 57 | x <- posterior::as_draws(x) 58 | if (!is.null(log_prior)) { 59 | log_prior <- posterior::as_draws(log_prior) 60 | } 61 | if (!is.null(log_lik)) { 62 | log_lik <- posterior::as_draws(log_lik) 63 | } 64 | log_prior_name <- as.character(log_prior_name) 65 | log_lik_name <- as.character(log_lik_name) 66 | 67 | # input checks 68 | checkmate::assert_true(posterior::ndraws(x) > 0) 69 | 70 | checkmate::assertClass(log_prior, "draws", null.ok = TRUE) 71 | checkmate::assertClass(log_lik, "draws", null.ok = TRUE) 72 | 73 | checkmate::assertCharacter(log_lik_name, any.missing = FALSE) 74 | checkmate::assertCharacter(log_prior_name, any.missing = FALSE) 75 | 76 | checkmate::assertFunction(log_prior_fn, null.ok = TRUE) 77 | checkmate::assertFunction(log_lik_fn, null.ok = TRUE) 78 | checkmate::assertFunction(log_ratio_fn, null.ok = TRUE) 79 | 80 | if (is.null(log_prior)) { 81 | if (is.null(fit)) { 82 | log_prior <- log_prior_fn(x, log_prior_name = log_prior_name, ...) 83 | } else { 84 | log_prior <- log_prior_fn(fit, log_prior_name = log_prior_name, ...) 85 | } 86 | } 87 | 88 | if (is.null(log_lik)) { 89 | if (is.null(fit)) { 90 | log_lik <- log_lik_fn(x, ...) 91 | } else { 92 | log_lik <- log_lik_fn(fit, ...) 93 | } 94 | } 95 | 96 | checkmate::assert_false(checkmate::anyMissing(log_prior)) 97 | checkmate::assert_false(checkmate::anyMissing(log_lik)) 98 | 99 | psd <- list( 100 | draws = remove_unwanted_vars(x), 101 | fit = fit, 102 | log_prior_fn = log_prior_fn, 103 | log_lik_fn = log_lik_fn, 104 | log_prior = log_prior, 105 | log_lik = log_lik, 106 | log_ratio_fn = log_ratio_fn 107 | ) 108 | 109 | class(psd) <- c("priorsense_data", class(psd)) 110 | 111 | return(psd) 112 | } 113 | 114 | ##' @rdname create-priorsense-data 115 | ##' @export 116 | create_priorsense_data.stanfit <- function(x, ...) { 117 | 118 | create_priorsense_data.default( 119 | x = get_draws_stanfit(x), 120 | fit = x, 121 | log_prior_fn = log_prior_draws, 122 | log_lik_fn = log_lik_draws, 123 | log_prior = log_prior_draws(x, ...), 124 | log_lik = log_lik_draws(x, ...), 125 | log_ratio_fn = powerscale_log_ratio_fun, 126 | ... 127 | ) 128 | } 129 | 130 | ##' @rdname create-priorsense-data 131 | ##' @export 132 | create_priorsense_data.CmdStanFit <- function(x, ...) { 133 | 134 | create_priorsense_data.default( 135 | x = get_draws_CmdStanFit(x, ...), 136 | fit = x, 137 | log_prior_fn = log_prior_draws, 138 | log_lik_fn = log_lik_draws, 139 | log_prior = log_prior_draws(x, ...), 140 | log_lik = log_lik_draws(x, ...), 141 | log_ratio_fn = powerscale_log_ratio_fun, 142 | ... 143 | ) 144 | } 145 | 146 | ##' @rdname create-priorsense-data 147 | ##' @export 148 | create_priorsense_data.draws <- function(x, ...) { 149 | 150 | create_priorsense_data.default( 151 | x = x, 152 | ... 153 | ) 154 | } 155 | 156 | 157 | 158 | ##' @rdname create-priorsense-data 159 | ##' @export 160 | create_priorsense_data.rjags <- function(x, ...) { 161 | 162 | create_priorsense_data( 163 | x = posterior::as_draws(x$BUGSoutput$sims.array), 164 | ... 165 | ) 166 | } 167 | -------------------------------------------------------------------------------- /R/cumulative_plot.R: -------------------------------------------------------------------------------- 1 | ##' stat ewcdf 2 | ##' 3 | ##' @param mapping aesthetic mapping 4 | ##' @param data data for plotting 5 | ##' @param ... unused 6 | ##' @return LayerInstance object 7 | ##' @keywords internal 8 | ##' @noRd 9 | stat_ewcdf <- function(mapping = NULL, data = NULL, 10 | ...) { 11 | # Code adapted from 12 | # https://github.com/finnlindgren/StatCompLab/blob/main/R/ggplot.R and 13 | # https://rdrr.io/github/tidyverse/ggplot2/src/R/stat-ecdf.r 14 | 15 | # TODO: when ggplot2 version 3.5.2 is release, switch to ggplot2 version 16 | ggplot2::layer( 17 | data = data, 18 | mapping = mapping, 19 | stat = StatEwcdf, 20 | geom = "step", 21 | position = "identity", 22 | show.legend = NA, 23 | inherit.aes = TRUE, 24 | params = list( 25 | n = NULL, 26 | pad = TRUE, 27 | na.rm = FALSE 28 | ) 29 | ) 30 | } 31 | 32 | 33 | StatEwcdf <- ggplot2::ggproto( 34 | "StatEwcdf", ggplot2::Stat, 35 | required_aes = c("x|y", "weight"), 36 | 37 | default_aes = ggplot2::aes(y = ggplot2::after_stat(y)), 38 | 39 | setup_params = function(data, params) { 40 | params$flipped_aes <- 41 | ggplot2::has_flipped_aes(data, 42 | params, 43 | main_is_orthogonal = FALSE, 44 | main_is_continuous = TRUE) 45 | 46 | has_x <- !(is.null(data$x) && is.null(params$x)) 47 | has_y <- !(is.null(data$y) && is.null(params$y)) 48 | has_weights <- !(is.null(data$weight) && is.null(params$weight)) 49 | 50 | params 51 | }, 52 | 53 | compute_group = function(data, scales, n = NULL, 54 | pad = TRUE, flipped_aes = FALSE) { 55 | data <- ggplot2::flip_data(data, flipped_aes) 56 | # If n is NULL, use raw values; otherwise interpolate 57 | if (is.null(n)) { 58 | x <- unique(data$x) 59 | } else { 60 | x <- seq(min(data$x), max(data$x), length.out = n) 61 | } 62 | 63 | if (pad) { 64 | x <- c(-Inf, x, Inf) 65 | } 66 | if (is.null(data$weight)) { 67 | data_ecdf <- stats::ecdf(data$x)(x) 68 | } else { 69 | data_ecdf <- 70 | ewcdf( 71 | data$x, 72 | weights = data$weight / sum(data$weight) 73 | )(x) 74 | } 75 | 76 | df_ecdf <- data.frame(x = x, y = data_ecdf) 77 | df_ecdf$flipped_aes <- flipped_aes 78 | ggplot2::flip_data(df_ecdf, flipped_aes) 79 | 80 | }, 81 | dropped_aes = "weight" 82 | ) 83 | -------------------------------------------------------------------------------- /R/ewcdf.R: -------------------------------------------------------------------------------- 1 | # code adapted from spatstat.geom (c) Adrian Baddeley, Rolf Turner, Ege Rubak 2 | ewcdf <- function(x, weights = NULL) { 3 | x_idx <- order(x) 4 | x <- x[x_idx] 5 | weights <- weights[x_idx] 6 | 7 | nw <- length(weights) 8 | weighted <- (nw > 0) 9 | 10 | rl <- rle(x) 11 | vals <- rl$values 12 | if (!weighted) { 13 | wmatch <- rl$lengths 14 | } else { 15 | wmatch <- tabsumweight(x, weights) 16 | } 17 | ## cumulative weight in each interval 18 | cumwt <- cumsum(wmatch) 19 | totwt <- sum(wmatch) 20 | ## rescale 21 | cumwt <- cumwt / totwt 22 | totwt <- 1 23 | ## make function 24 | rval <- stats::approxfun( 25 | vals, cumwt, 26 | method = "constant", yleft = 0, yright = totwt, 27 | f = 0, ties = "ordered" 28 | ) 29 | class(rval) <- c("ewcdf", 30 | "ecdf", 31 | "stepfun", class(rval)) 32 | assign("weights", weights, envir = environment(rval)) 33 | attr(rval, "call") <- sys.call() 34 | return(rval) 35 | } 36 | 37 | tabsumweight <- function(x, weights) { 38 | v <- unique(sort(x)) 39 | nv <- length(v) 40 | out <- rep(0, times = nv) 41 | for (xi in x) { 42 | vi <- min(which(v >= xi)) 43 | out[vi] <- out[vi] + weights[vi] 44 | } 45 | return(out) 46 | } 47 | -------------------------------------------------------------------------------- /R/example_powerscale_model.R: -------------------------------------------------------------------------------- 1 | ##' Example Stan model for power-scaling 2 | ##' 3 | ##' Provides example models (with data) that are ready for use with 4 | ##' power-scaling. 5 | ##' @param model Character specifying which model code to 6 | ##' return. Currently "univariate_normal" and "eight_schools" are 7 | ##' implemented. 8 | ##' @return List containing model code and corresponding data. 9 | ##' @srrstats {G5.1} This function exposes two example data sets. 10 | ##' @examples 11 | ##' ex_normal <- example_powerscale_model(model = "univariate_normal") 12 | ##' 13 | ##' ex_eightschools <- example_powerscale_model(model = "eight_schools") 14 | ##' @export 15 | example_powerscale_model <- function(model = "univariate_normal") { 16 | 17 | examples <- powerscale_examples() 18 | 19 | return( 20 | list( 21 | model_code = examples[[model]][["model_code"]], 22 | data = examples[[model]][["data"]], 23 | draws = examples[[model]][["draws"]] 24 | ) 25 | ) 26 | } 27 | 28 | powerscale_examples <- function() { 29 | 30 | list( 31 | univariate_normal = 32 | list( 33 | model_code = "data { 34 | int N; 35 | array[N] real y; 36 | 37 | vector[2] prior_alpha; 38 | 39 | real likelihood_alpha; 40 | } 41 | parameters { 42 | real mu; 43 | real sigma; 44 | } 45 | transformed parameters { 46 | vector[2] lprior; 47 | // priors 48 | lprior[1] = normal_lpdf(mu | 0, 1); 49 | lprior[2] = normal_lpdf(sigma | 0, 2.5); 50 | } 51 | model { 52 | target += dot_product(prior_alpha, lprior); 53 | // likelihood 54 | target += likelihood_alpha * normal_lpdf(y | mu, sigma); 55 | } 56 | generated quantities { 57 | vector[N] log_lik; 58 | // likelihood 59 | for (n in 1:N) log_lik[n] = normal_lpdf(y[n] | mu, sigma); 60 | } 61 | 62 | ", 63 | data = list( 64 | y = c(9.5, 10.2, 9.1, 9.1, 10.3, 10.9, 11.7, 10.3, 9.6, 8.6, 9.1, 65 | 11.1, 9.3, 10.5, 9.7, 10.3, 10.0, 9.8, 9.6, 8.3, 10.2, 9.8, 66 | 10.0, 10.0, 9.1), 67 | N = 25, 68 | prior_alpha = c(1, 1), 69 | likelihood_alpha = 1 70 | ), 71 | draws = get("draws_univariate_normal", asNamespace("priorsense")) 72 | ), 73 | eight_schools = 74 | list( 75 | model_code = "data { 76 | int J; // number of schools 77 | array[J] real y; // estimated treatment effects 78 | array[J] real sigma; // s.e. of effect estimates 79 | real prior_alpha; // power-scaling 80 | real likelihood_alpha; // power-scaling 81 | } 82 | parameters { 83 | vector[J] theta_trans; // transformation of theta 84 | real mu; // hyper-parameter of mean 85 | real tau; // hyper-parameter of sd 86 | } 87 | transformed parameters{ 88 | vector[J] theta; 89 | // original theta 90 | theta = theta_trans * tau + mu; 91 | } 92 | model { 93 | // priors 94 | target += normal_lpdf(theta_trans | 0, 1); 95 | target += prior_alpha * normal_lpdf(mu | 0, 5); 96 | target += prior_alpha * cauchy_lpdf(tau | 0, 5); 97 | 98 | //likelihood 99 | target += likelihood_alpha * normal_lpdf(y | theta, sigma); 100 | } 101 | generated quantities { 102 | vector[J] log_lik; 103 | real lprior; 104 | for (j in 1:J) 105 | log_lik[j] = normal_lpdf(y[j] | theta[j], sigma[j]); 106 | 107 | // priors to power-scale 108 | lprior = cauchy_lpdf(tau | 0, 5) 109 | + normal_lpdf(mu | 0, 5); 110 | } 111 | 112 | ", 113 | data = list( 114 | J = 8, 115 | y = c(28, 8, -3, 7, -1, 1, 18, 12), 116 | sigma = c(15, 10, 16, 11, 9, 11, 10, 18), 117 | prior_alpha = 1, 118 | likelihood_alpha = 1 119 | ), 120 | draws = get("draws_eight_schools", asNamespace("priorsense")) 121 | ) 122 | ) 123 | } 124 | -------------------------------------------------------------------------------- /R/find_alpha_threshold.R: -------------------------------------------------------------------------------- 1 | ##' find alpha value with pareto-k lower than threshold 2 | ##' @param x object 3 | ##' @param ... additional arguments passed to methods 4 | ##' @return numeric value of alpha for which threshold is not reached 5 | ##' @srrstats {EA4.1} epsilon controls numeric precision 6 | ##' @noRd 7 | ##' @srrstats {G3.0} Numeric equality comparisons use appropriate 8 | ##' tolerances for approximate equality.* 9 | find_alpha_threshold <- function(x, ...) { 10 | UseMethod("find_alpha_threshold") 11 | 12 | } 13 | 14 | ##' @export 15 | find_alpha_threshold.default <- function(x, ...) { 16 | 17 | psd <- create_priorsense_data(x, ...) 18 | 19 | find_alpha_threshold(psd, ...) 20 | 21 | } 22 | 23 | ##' @export 24 | find_alpha_threshold.priorsense_data <- function(x, 25 | component, 26 | alpha_bound, 27 | epsilon = 0.00001, 28 | moment_match = FALSE, 29 | selection = NULL, 30 | ...) { 31 | checkmate::assert_number(alpha_bound, lower = 0) 32 | checkmate::assert_number(epsilon, lower = 0) 33 | checkmate::assert_choice(component, c("prior", "likelihood")) 34 | 35 | if (alpha_bound < 1) { 36 | lower <- alpha_bound 37 | upper <- 1 - epsilon 38 | } else if (alpha_bound > 1) { 39 | lower <- 1 + epsilon 40 | upper <- alpha_bound 41 | } 42 | 43 | if (lower < 1 && upper < 1) { 44 | comparison <- below_one_comparison 45 | } else if (lower > 1 && upper > 1) { 46 | comparison <- above_one_comparison 47 | } 48 | 49 | pareto_k <- -Inf # set inital low pareto_k 50 | alpha <- (lower + upper) / 2 51 | continue <- TRUE 52 | 53 | while (continue) { 54 | 55 | # calculate criterion 56 | new_pareto_k_diags <- get_powerscaling_details( 57 | suppressWarnings( 58 | powerscale( 59 | x = x, 60 | alpha = alpha, 61 | component = component, 62 | moment_match = moment_match, 63 | selection = selection, 64 | ... 65 | ) 66 | ))$diagnostics 67 | 68 | new_pareto_k <- new_pareto_k_diags$khat 69 | new_khat_threshold <- new_pareto_k_diags$khat_threshold 70 | 71 | compare <- comparison(new_pareto_k, pareto_k, 72 | new_khat_threshold, epsilon) 73 | 74 | # check criterion 75 | if (compare == "left") { 76 | upper <- alpha 77 | alpha <- (lower + alpha) / 2 78 | } else if (compare == "right") { 79 | lower <- alpha 80 | alpha <- (alpha + upper) / 2 81 | } else if (compare == "stop") { 82 | continue <- FALSE 83 | } 84 | pareto_k <- new_pareto_k 85 | } 86 | 87 | # be conservative to ensure pareto_k lower 88 | alpha <- ifelse(alpha > 1, alpha - epsilon, alpha + epsilon) 89 | 90 | return(alpha) 91 | } 92 | 93 | ##' above one comparison 94 | ##' @param new_pareto_k numeric new pareto-k 95 | ##' @param pareto_k numeric current pareto-k 96 | ##' @param k_threshold numeric k threshold 97 | ##' @param epsilon numeric tolerance 98 | ##' @return character specifying direction of next value 99 | ##' @noRd 100 | above_one_comparison <- function(new_pareto_k, 101 | pareto_k, 102 | k_threshold, 103 | epsilon) { 104 | if (abs(new_pareto_k - pareto_k) < epsilon) { 105 | return("stop") 106 | } else if (new_pareto_k >= k_threshold) { 107 | return("left") 108 | } else if (new_pareto_k < k_threshold) { 109 | return("right") 110 | } 111 | } 112 | 113 | ##' below one comparison 114 | ##' @param new_pareto_k numeric new pareto-k 115 | ##' @param pareto_k numeric current pareto-k 116 | ##' @param k_threshold numeric k threshold 117 | ##' @param epsilon numeric tolerance 118 | ##' @return character specifying direction of next value 119 | ##' @noRd 120 | below_one_comparison <- function(new_pareto_k, 121 | pareto_k, 122 | k_threshold, 123 | epsilon) { 124 | if (abs(new_pareto_k - pareto_k) < epsilon) { 125 | return("stop") 126 | } else if (new_pareto_k < k_threshold) { 127 | return("left") 128 | } else if (new_pareto_k >= k_threshold) { 129 | return("right") 130 | } 131 | } 132 | -------------------------------------------------------------------------------- /R/get_draws.R: -------------------------------------------------------------------------------- 1 | get_draws_stanfit <- function(x, variable = NULL, 2 | excluded_variables = c( 3 | "lprior", "lp__", "log_lik" 4 | ), 5 | ...) { 6 | if (is.null(variable)) { 7 | draws <- remove_unwanted_vars(x) 8 | } else { 9 | draws <- posterior::as_draws_df(as.array(x)) 10 | } 11 | 12 | return(draws) 13 | } 14 | 15 | get_draws_CmdStanFit <- function(x, variable = NULL, regex, 16 | excluded_variables = c( 17 | "lprior", "lp__", "log_lik" 18 | ), 19 | ...) { 20 | 21 | if (is.null(variable)) { 22 | draws <- remove_unwanted_vars(x) 23 | } else { 24 | draws <- posterior::as_draws_df(x$draws()) 25 | } 26 | return(draws) 27 | } 28 | -------------------------------------------------------------------------------- /R/ggplot_theme.R: -------------------------------------------------------------------------------- 1 | ##' default priorsense colors 2 | ##' 3 | ##' @return list of colors for priorsense plots 4 | ##' @noRd 5 | default_priorsense_colors <- function() { 6 | return(c("#1981FA", "#221F21", "#E65041", "#440154", "#FDE725")) 7 | } 8 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | ##' stop without call 2 | ##' @keywords internal 3 | ##' @noRd 4 | ##' @param ... 5 | stop2 <- function(...) { 6 | stop(..., call. = FALSE) 7 | } 8 | 9 | ##' row sums for draws objects 10 | ##' @param x draws object 11 | ##' @return draws object with rows summed 12 | ##' @keywords internal 13 | ##' @noRd 14 | rowsums_draws <- function(x) { 15 | posterior::draws_array( 16 | sum = rowSums( 17 | posterior::as_draws_array(x), 18 | dims = 2 19 | ), 20 | .nchains = posterior::nchains(x) 21 | ) 22 | } 23 | 24 | ##' remove unwanted variables 25 | ##' @param x draws object 26 | ##' @param excluded_variables character vector specifying variables to remove 27 | ##' @param regex flag indicating whether to match with regex 28 | ##' @param ... unused 29 | ##' @return draws object without excluded variables 30 | ##' @keywords internal 31 | ##' @noRd 32 | remove_unwanted_vars <- function(x, 33 | excluded_variables = c( 34 | "lprior", 35 | "log_lik", 36 | "lp__" 37 | ), 38 | regex = TRUE, ...) { 39 | 40 | draws <- posterior::as_draws_df(x) 41 | 42 | draws <- posterior::subset_draws(draws, 43 | variable = excluded_variables, 44 | exclude = TRUE, 45 | regex = regex) 46 | 47 | return(draws) 48 | } 49 | ##' require package 50 | ##' 51 | ##' @param package character specifying which package is required 52 | ##' @param version character specifying which version is required, 53 | ##' default is NULL, implying any version is acceptable 54 | ##' @param message message to display if package is not installed 55 | ##' @return invisibly returns `TRUE` 56 | ##' @keywords internal 57 | ##' @noRd 58 | require_package <- function(package, version = NULL, message = NULL) { 59 | if (!requireNamespace(package, quietly = TRUE)) { 60 | stop2("Please install the '", package, "' package", message) 61 | } 62 | if (!is.null(version)) { 63 | version <- as.package_version(version) 64 | if (utils::packageVersion(package) < version) { 65 | stop2("Please install package '", package, 66 | "' version ", version, " or higher.") 67 | } 68 | } 69 | invisible(TRUE) 70 | } 71 | 72 | ##' get power-scaling details 73 | ##' @param x object with powerscaling attribute 74 | ##' @return powerscaling attribute 75 | ##' @keywords internal 76 | ##' @noRd 77 | get_powerscaling_details <- function(x) { 78 | attr(x, "powerscaling") 79 | } 80 | 81 | ##' is constant 82 | ##' @param x numeric vector to check for constant 83 | ##' @param tol tolerance 84 | ##' @keywords internal 85 | ##' @noRd 86 | is_constant <- function(x, tol = .Machine$double.eps) { 87 | x <- posterior::as_draws_array(x) 88 | abs(max(x) - min(x)) < tol 89 | } 90 | -------------------------------------------------------------------------------- /R/log_lik_draws.R: -------------------------------------------------------------------------------- 1 | ##' Extract log likelihood draws 2 | ##' 3 | ##' Extract log likelihood from fitted model and return as a draws 4 | ##' object. 5 | ##' 6 | ##' @name log_lik_draws 7 | ##' 8 | ##' @param x Model fit or draws object. 9 | ##' @param joint Logical indicating whether to return the joint log 10 | ##' likelihood or array. Default is FALSE. 11 | ##' @param log_lik_name Name of parameter in Stan model corresponding 12 | ##' to log likelihood, default is "log_lik". 13 | ##' @param ... Arguments passed to individual methods. 14 | ##' @return A draws_array object containing log_lik values. 15 | ##' @examples 16 | ##' ex <- example_powerscale_model() 17 | ##' drw <- ex$draws 18 | ##' 19 | ##' log_lik_draws(drw) 20 | ##' 21 | ##' @export 22 | log_lik_draws <- function(x, ...) { 23 | UseMethod("log_lik_draws") 24 | } 25 | 26 | ##' @rdname log_lik_draws 27 | ##' @export 28 | log_lik_draws.stanfit <- function(x, joint = FALSE, 29 | log_lik_name = "log_lik", ...) { 30 | log_lik <- as.array(x, pars = log_lik_name) 31 | 32 | log_lik <- posterior::as_draws_array(log_lik) 33 | 34 | if (joint) { 35 | log_lik <- rowsums_draws(log_lik) 36 | posterior::variables(log_lik) <- log_lik_name 37 | } 38 | 39 | return(log_lik) 40 | } 41 | 42 | ##' @rdname log_lik_draws 43 | ##' @export 44 | log_lik_draws.CmdStanFit <- function(x, joint = FALSE, 45 | log_lik_name = "log_lik", ...) { 46 | 47 | log_lik <- x$draws(variables = log_lik_name) 48 | 49 | if (joint) { 50 | log_lik <- rowsums_draws(log_lik) 51 | posterior::variables(log_lik) <- log_lik_name 52 | } 53 | 54 | return(log_lik) 55 | } 56 | 57 | ##' @rdname log_lik_draws 58 | ##' @export 59 | log_lik_draws.draws <- function(x, joint = FALSE, 60 | log_lik_name = "log_lik", ...) { 61 | 62 | log_lik <- posterior::subset_draws(x, variable = log_lik_name) 63 | 64 | if (joint) { 65 | log_lik <- rowsums_draws(log_lik) 66 | posterior::variables(log_lik) <- log_lik_name 67 | } 68 | 69 | return(log_lik) 70 | } 71 | -------------------------------------------------------------------------------- /R/log_prior_draws.R: -------------------------------------------------------------------------------- 1 | ##' Extract log prior draws 2 | ##' 3 | ##' Extract log likelihood from fitted model and return as a draws 4 | ##' object. 5 | ##' 6 | ##' @name log_prior_draws 7 | ##' 8 | ##' @param x Model fit or draws object. 9 | ##' @param joint Logical indicating whether to return the joint log 10 | ##' prior or array. Default is FALSE. 11 | ##' @param log_prior_name Name of parameter in Stan model 12 | ##' corresponding to log prior, default is "lprior". 13 | ##' @param ... Arguments passed to individual methods. 14 | ##' @return A draws_array object containing log_prior values. 15 | ##' @examples 16 | ##' ex <- example_powerscale_model() 17 | ##' drw <- ex$draws 18 | ##' 19 | ##' log_prior_draws(drw) 20 | ##' 21 | ##' @export 22 | log_prior_draws <- function(x, ...) { 23 | UseMethod("log_prior_draws") 24 | } 25 | 26 | 27 | ##' @rdname log_prior_draws 28 | ##' @export 29 | log_prior_draws.stanfit <- function(x, joint = FALSE, 30 | log_prior_name = "lprior", ...) { 31 | 32 | if (!inherits(x, "stanfit")) 33 | stop("Not a stanfit object.", call. = FALSE) 34 | if (x@mode != 0) 35 | stop("Stan model does not contain posterior draws.", 36 | call. = FALSE) 37 | if (!requireNamespace("rstan", quietly = TRUE)) 38 | stop("Please load the 'rstan' package.", call. = FALSE) 39 | 40 | checkmate::assert_logical(joint, len = 1) 41 | checkmate::assert_character(log_prior_name, len = 1) 42 | 43 | log_prior <- posterior::subset_draws( 44 | posterior::as_draws_array(x), 45 | variable = paste0("^", log_prior_name), regex = TRUE 46 | ) 47 | 48 | if (joint) { 49 | log_prior <- rowsums_draws(log_prior) 50 | posterior::variables(log_prior) <- log_prior_name 51 | } 52 | 53 | return(log_prior) 54 | } 55 | 56 | ##' @rdname log_prior_draws 57 | ##' @export 58 | log_prior_draws.CmdStanFit <- function(x, joint = FALSE, 59 | log_prior_name = "lprior", ...) { 60 | 61 | checkmate::assert_logical(joint, len = 1) 62 | checkmate::assert_character(log_prior_name, len = 1) 63 | 64 | all_draws <- x$draws() 65 | 66 | log_prior <- posterior::subset_draws( 67 | all_draws, 68 | variables = paste0("^", log_prior_name), 69 | regex = TRUE 70 | ) 71 | 72 | if (joint) { 73 | log_prior <- rowsums_draws(log_prior) 74 | posterior::variables(log_prior) <- log_prior_name 75 | } 76 | 77 | 78 | return(log_prior) 79 | } 80 | 81 | ##' @rdname log_prior_draws 82 | ##' @export 83 | log_prior_draws.draws <- function(x, joint = FALSE, 84 | log_prior_name = "lprior", ...) { 85 | 86 | checkmate::assert_logical(joint, len = 1) 87 | checkmate::assert_character(log_prior_name, len = 1) 88 | 89 | log_prior <- posterior::subset_draws(x, 90 | variable = paste0("^", log_prior_name), 91 | regex = TRUE) 92 | 93 | if (joint) { 94 | log_prior <- rowsums_draws(log_prior) 95 | posterior::variables(log_prior) <- log_prior_name 96 | } 97 | 98 | return(log_prior) 99 | } 100 | -------------------------------------------------------------------------------- /R/measure_divergence.R: -------------------------------------------------------------------------------- 1 | ##' Calculate specified divergence measures for each posterior 2 | ##' 3 | ##' @param draws1 draws of first distribution 4 | ##' @param draws2 draws of second distribution 5 | ##' @param measure divergence measure 6 | ##' @param measure_args arguments for divergence measure 7 | ##' @param ... unused 8 | ##' @return a tibble 9 | ##' @keywords internal 10 | ##' @noRd 11 | measure_divergence <- function(draws1, draws2, 12 | measure, 13 | measure_args = list(), 14 | ...) { 15 | 16 | draws1 <- posterior::as_draws_df(draws1) 17 | draws2 <- posterior::as_draws_df(draws2) 18 | 19 | weights1 <- stats::weights(draws1, log = FALSE) 20 | weights2 <- stats::weights(draws2, log = FALSE) 21 | 22 | variables <- posterior::variables(draws1) 23 | 24 | out <- tibble::as_tibble_col(variables, "variable") 25 | 26 | for (m in measure) { 27 | divs <- numeric(length(variables)) 28 | names(divs) <- variables 29 | for (v in variables) { 30 | 31 | args <- c( 32 | list( 33 | x = draws1[[v]], 34 | y = draws2[[v]], 35 | x_weights = weights1, 36 | y_weights = weights2 37 | ), 38 | measure_args 39 | ) 40 | 41 | divs[v] <- do.call( 42 | what = m, 43 | args = args 44 | ) 45 | } 46 | divs <- tibble::as_tibble_col(divs, column_name = m) 47 | out <- cbind(out, divs) 48 | } 49 | 50 | return(out) 51 | } 52 | -------------------------------------------------------------------------------- /R/powerscale_derivative.R: -------------------------------------------------------------------------------- 1 | ##' Derivative with respect to power-scaling 2 | ##' 3 | ##' Calculate the analytical derivative of a quantity with respect to 4 | ##' power-scaling prior or likelihood. 5 | ##' 6 | ##' @param x draws object of posterior draws 7 | ##' @param log_component numeric vector of log likelihood or log prior values 8 | ##' @param quantity Character specifying quantity of interest (default 9 | ##' is "mean"). Options are "mean", "sd", "var". 10 | ##' @param ... unused 11 | ##' @return Derivative of the quantity with respect to log2 of the 12 | ##' power-scaling factor (alpha). 13 | ##' 14 | ##' @examples 15 | ##' example_model <- example_powerscale_model() 16 | ##' draws <- example_model$draws 17 | ##' log_prior <- log_prior_draws(draws, joint = TRUE) 18 | ##' posterior::summarise_draws( 19 | ##' posterior::subset_draws(draws, variable = c("mu", "sigma")), 20 | ##' mean, 21 | ##' mean_sens = ~powerscale_derivative(.x, log_prior, quantity = "mean") 22 | ##' ) 23 | ##' @export 24 | powerscale_derivative <- function(x, 25 | log_component, 26 | quantity = "mean", 27 | ...) { 28 | 29 | log_component <- as.numeric(log_component) 30 | 31 | if (quantity %in% c("median", "mad", "q5", "q95")) { 32 | out <- NA 33 | warning("Power-scaling derivative for medians or quantiles is zero. Consider using powerscale_gradients instead.") 34 | 35 | } else if (quantity == "mean") { 36 | # adapted from method by Topi Paananen 37 | deriv_first_moment <- mean(x * log_component) - 38 | mean(x) * mean(log_component) 39 | 40 | # wrt log_2(alpha) 41 | out <- log(2) * deriv_first_moment 42 | 43 | } else if (quantity == "sd") { 44 | 45 | first_moment <- mean(x) 46 | second_moment <- mean(x^2) 47 | 48 | deriv_first_moment <- mean(x * log_component) - 49 | mean(x) * mean(log_component) 50 | 51 | deriv_second_moment <- mean(x^2 * log_component) - 52 | mean(x^2) * mean(log_component) 53 | 54 | out <- log(2) * ((deriv_second_moment - 55 | 2 * deriv_first_moment * first_moment) * 56 | 0.5 / sqrt(second_moment - first_moment^2)) 57 | 58 | } else if (quantity == "var") { 59 | 60 | first_moment <- mean(x) 61 | 62 | deriv_first_moment <- mean(x * log_component) - 63 | mean(x) * mean(log_component) 64 | 65 | deriv_second_moment <- mean(x^2 * log_component) - 66 | mean(x^2) * mean(log_component) 67 | 68 | out <- log(2) * 69 | (deriv_second_moment - 70 | 2 * deriv_first_moment * first_moment) 71 | } 72 | 73 | names(out) <- paste0("psens_", quantity) 74 | 75 | return(out) 76 | } 77 | -------------------------------------------------------------------------------- /R/powerscale_sensitivity.R: -------------------------------------------------------------------------------- 1 | ##' Power-scaling sensitivity analysis 2 | ##' 3 | ##' Calculates the prior/likelihood sensitivity based on power-scaling 4 | ##' perturbations. This is done using importance sampling (and 5 | ##' optionally moment matching). 6 | ##' @template fit_arg 7 | ##' @name powerscale-sensitivity 8 | ##' @param x Model fit object or priorsense_data object. 9 | ##' @param ... Further arguments passed to functions. 10 | ##' @param variable Character vector of variables to check. 11 | ##' @param lower_alpha Lower alpha value for gradient calculation. 12 | ##' @param upper_alpha Upper alpha value for gradient calculation. 13 | ##' @param component Character vector specifying component(s) to scale 14 | ##' (default is both "prior" and "likelihood"). 15 | ##' @param sensitivity_threshold Threshold for flagging variable as 16 | ##' sensitive to power-scaling. 17 | ##' @template div_measure_arg 18 | ##' @template powerscale_args 19 | ##' @template prediction_arg 20 | ##' @template resample_arg 21 | ##' @template selection_arg 22 | ##' @template log_comp_name 23 | ##' @param num_args (named list) Optional arguments passed to 24 | ##' [num()][tibble::num] for pretty printing of summaries. Can be 25 | ##' controlled globally via the `posterior.num_args` 26 | ##' [option][base::options]. 27 | ##' @return Table of sensitivity values for each specified variable. 28 | ##' @template powerscale_references 29 | ##' @srrstats {EA3.0} summary output of algorithm is provided 30 | ##' @examples 31 | ##' ex <- example_powerscale_model() 32 | ##' powerscale_sensitivity(ex$draws) 33 | ##' @export 34 | powerscale_sensitivity <- function(x, ...) { 35 | UseMethod("powerscale_sensitivity") 36 | } 37 | 38 | ##' @rdname powerscale-sensitivity 39 | ##' @export 40 | powerscale_sensitivity.default <- function(x, 41 | variable = NULL, 42 | lower_alpha = 0.99, 43 | upper_alpha = 1.01, 44 | div_measure = "cjs_dist", 45 | measure_args = list(), 46 | component = c( 47 | "prior", 48 | "likelihood" 49 | ), 50 | sensitivity_threshold = 0.05, 51 | moment_match = FALSE, 52 | k_threshold = 0.5, 53 | resample = FALSE, 54 | transform = NULL, 55 | prediction = NULL, 56 | prior_selection = NULL, 57 | likelihood_selection = NULL, 58 | log_prior_name = "lprior", 59 | log_lik_name = "log_lik", 60 | num_args = NULL, 61 | ... 62 | ) { 63 | 64 | psd <- create_priorsense_data( 65 | x = x, 66 | log_prior_name = log_prior_name, 67 | log_lik_name = log_lik_name, 68 | ... 69 | ) 70 | 71 | powerscale_sensitivity.priorsense_data( 72 | psd, 73 | variable = variable, 74 | lower_alpha = lower_alpha, 75 | upper_alpha = upper_alpha, 76 | div_measure = div_measure, 77 | measure_args = measure_args, 78 | component = component, 79 | sensitivity_threshold = sensitivity_threshold, 80 | moment_match = moment_match, 81 | k_threshold = k_threshold, 82 | resample = resample, 83 | transform = transform, 84 | prediction = prediction, 85 | prior_selection = prior_selection, 86 | likelihood_selection = likelihood_selection, 87 | num_args = num_args, 88 | ... 89 | ) 90 | 91 | } 92 | 93 | ##' @rdname powerscale-sensitivity 94 | ##' @export 95 | powerscale_sensitivity.priorsense_data <- function(x, 96 | variable = NULL, 97 | lower_alpha = 0.99, 98 | upper_alpha = 1.01, 99 | div_measure = "cjs_dist", 100 | measure_args = list(), 101 | component = c( 102 | "prior", 103 | "likelihood" 104 | ), 105 | sensitivity_threshold = 0.05, 106 | moment_match = FALSE, 107 | k_threshold = 0.5, 108 | resample = FALSE, 109 | transform = NULL, 110 | prediction = NULL, 111 | prior_selection = NULL, 112 | likelihood_selection = NULL, 113 | num_args = NULL, 114 | ...) { 115 | component <- tolower(component) 116 | 117 | # input checks 118 | checkmate::assertCharacter(variable, null.ok = TRUE) 119 | checkmate::assertNumber(lower_alpha, lower = 0, upper = 1) 120 | checkmate::assertNumber(upper_alpha, lower = 1) 121 | checkmate::assertCharacter(div_measure, len = 1) 122 | checkmate::assertList(measure_args) 123 | checkmate::assertLogical(moment_match, len = 1) 124 | checkmate::assertSubset(component, c("prior", "likelihood")) 125 | checkmate::assertNumber(sensitivity_threshold, lower = 0) 126 | checkmate::assertNumber(k_threshold, null.ok = TRUE) 127 | checkmate::assertLogical(resample, len = 1) 128 | checkmate::assertCharacter(transform, null.ok = TRUE, len = 1) 129 | checkmate::assertFunction(prediction, null.ok = TRUE) 130 | 131 | gradients <- powerscale_gradients( 132 | x = x, 133 | variable = variable, 134 | component = component, 135 | type = "divergence", 136 | lower_alpha = lower_alpha, 137 | upper_alpha = upper_alpha, 138 | moment_match = moment_match, 139 | div_measure = div_measure, 140 | measure_args = measure_args, 141 | transform = transform, 142 | resample = resample, 143 | prediction = prediction, 144 | prior_selection = prior_selection, 145 | likelihood_selection = likelihood_selection, 146 | ... 147 | ) 148 | 149 | prior_sense <- gradients$divergence$prior[[2]] 150 | lik_sense <- gradients$divergence$likelihood[[2]] 151 | 152 | if (is.null(lik_sense)) { 153 | lik_sense <- NA 154 | } 155 | 156 | if (is.null(prior_sense)) { 157 | prior_sense <- NA 158 | } 159 | 160 | varnames <- unique(c(as.character(gradients$divergence$prior$variable), 161 | as.character(gradients$divergence$likelihood$variable))) 162 | 163 | sense <- data.frame( 164 | variable = varnames, 165 | prior = prior_sense, 166 | likelihood = lik_sense 167 | ) 168 | 169 | # categorise variables has prior-data conflict or uninformative 170 | # likelihood 171 | 172 | sense$diagnosis <- ifelse( 173 | sense$prior >= sensitivity_threshold & sense$likelihood >= sensitivity_threshold, "potential prior-data conflict", 174 | ifelse(sense$prior > sensitivity_threshold & sense$likelihood < sensitivity_threshold, 175 | "potential strong prior / weak likelihood", 176 | "-" 177 | ) 178 | ) 179 | 180 | out <- sense 181 | 182 | class(out) <- c("powerscaled_sensitivity_summary", class(out)) 183 | 184 | attr(out, "num_args") <- num_args 185 | attr(out, "div_measure") <- div_measure 186 | attr(out, "loadings") <- gradients$loadings 187 | attr(out, "prior_selection") <- prior_selection 188 | attr(out, "likelihood_selection") <- likelihood_selection 189 | 190 | return(out) 191 | } 192 | 193 | 194 | ##' @rdname powerscale-sensitivity 195 | ##' @export 196 | powerscale_sensitivity.CmdStanFit <- function(x, 197 | ... 198 | ) { 199 | 200 | psd <- create_priorsense_data.CmdStanFit(x) 201 | 202 | powerscale_sensitivity.priorsense_data( 203 | psd, 204 | ... 205 | ) 206 | } 207 | 208 | ##' @rdname powerscale-sensitivity 209 | ##' @export 210 | powerscale_sensitivity.stanfit <- function(x, 211 | ... 212 | ) { 213 | 214 | psd <- create_priorsense_data.stanfit(x, ...) 215 | 216 | powerscale_sensitivity.priorsense_data( 217 | psd, 218 | ... 219 | ) 220 | } 221 | -------------------------------------------------------------------------------- /R/powerscale_sequence.R: -------------------------------------------------------------------------------- 1 | ##' @rdname powerscale-overview 2 | ##' @export 3 | powerscale_sequence <- function(x, ...) { 4 | UseMethod("powerscale_sequence") 5 | 6 | } 7 | 8 | ##' @rdname powerscale-overview 9 | ##' @export 10 | powerscale_sequence.default <- function(x, 11 | lower_alpha = 0.8, 12 | upper_alpha = 1 / lower_alpha, 13 | length = 3, variable = NULL, 14 | component = c("prior", "likelihood"), 15 | moment_match = FALSE, 16 | k_threshold = 0.5, 17 | resample = FALSE, 18 | transform = NULL, 19 | prediction = NULL, 20 | auto_alpha_range = FALSE, 21 | symmetric = TRUE, 22 | prior_selection = NULL, 23 | likelihood_selection = NULL, 24 | ...) { 25 | psd <- create_priorsense_data(x, ...) 26 | powerscale_sequence( 27 | psd, 28 | lower_alpha = lower_alpha, 29 | upper_alpha = upper_alpha, 30 | length = length, 31 | variable = variable, 32 | component = component, 33 | moment_match = moment_match, 34 | k_threshold = k_threshold, 35 | resample = resample, 36 | transform = transform, 37 | prediction = prediction, 38 | auto_alpha_range = auto_alpha_range, 39 | symmetric = symmetric, 40 | prior_selection = prior_selection, 41 | likelihood_selection = likelihood_selection, 42 | ... 43 | ) 44 | } 45 | 46 | ##' @rdname powerscale-overview 47 | ##' @export 48 | powerscale_sequence.priorsense_data <- function(x, lower_alpha = 0.8, 49 | upper_alpha = 1 / lower_alpha, 50 | length = 3, variable = NULL, 51 | component = c("prior", "likelihood"), 52 | moment_match = FALSE, 53 | k_threshold = NULL, 54 | resample = FALSE, 55 | transform = NULL, 56 | prediction = NULL, 57 | auto_alpha_range = FALSE, 58 | symmetric = TRUE, 59 | prior_selection = NULL, 60 | likelihood_selection = NULL, 61 | ... 62 | ) { 63 | 64 | component <- tolower(as.character(component)) 65 | lower_alpha <- as.numeric(lower_alpha) 66 | upper_alpha <- as.numeric(upper_alpha) 67 | moment_match <- as.logical(moment_match) 68 | if (!is.null(k_threshold)) { 69 | k_threshold <- as.numeric(k_threshold) 70 | } 71 | resample <- as.logical(resample) 72 | if (!is.null(transform)) { 73 | transform <- as.character(transform) 74 | } 75 | if (!is.null(prediction)) { 76 | prediction <- as.function(prediction) 77 | } 78 | if (!is.null(variable)) { 79 | variable <- as.character(variable) 80 | } 81 | 82 | 83 | # input checks 84 | checkmate::assertFunction(prediction, null.ok = TRUE) 85 | checkmate::assertSubset(component, c("prior", "likelihood")) 86 | checkmate::assertNumber(lower_alpha) 87 | checkmate::assertNumber(upper_alpha) 88 | checkmate::assertNumber(length) 89 | checkmate::assertFlag(moment_match) 90 | checkmate::assertFlag(symmetric) 91 | checkmate::assertNumber(k_threshold, null.ok = TRUE) 92 | checkmate::assertFlag(resample) 93 | checkmate::assertChoice(transform, c("whiten", "scale", "identity"), null.ok = TRUE) 94 | checkmate::assertFunction(prediction, null.ok = TRUE) 95 | checkmate::assertCharacter(variable, null.ok = TRUE) 96 | 97 | # adapt alpha range to ensure pareto-k < theshold 98 | if (auto_alpha_range) { 99 | alpha_range <- list(prior = NULL, likelihood = NULL) 100 | for (comp in component) { 101 | lower_alpha <- find_alpha_threshold( 102 | x, 103 | component = comp, 104 | alpha_bound = lower_alpha, 105 | moment_match = moment_match, 106 | selection = get(paste0(comp, "_selection")) 107 | ) 108 | 109 | upper_alpha <- find_alpha_threshold( 110 | x, 111 | component = comp, 112 | alpha_bound = upper_alpha, 113 | moment_match = moment_match, 114 | selection = get(paste0(comp, "_selection")) 115 | ) 116 | alpha_range[[comp]] <- list(lower_alpha, upper_alpha) 117 | } 118 | lower_alpha <- max( 119 | alpha_range[["prior"]][[1]], 120 | alpha_range[["likelihood"]][[1]], 121 | na.rm = TRUE 122 | ) 123 | upper_alpha <- min( 124 | alpha_range[["prior"]][[2]], 125 | alpha_range[["likelihood"]][[2]], 126 | na.rm = TRUE 127 | ) 128 | } 129 | 130 | if (!symmetric) { 131 | alpha_seq <- seq( 132 | lower_alpha, 133 | upper_alpha, 134 | length.out = length 135 | ) 136 | } else { 137 | if (abs(log(lower_alpha, 2)) < abs(log(upper_alpha, 2))) { 138 | alpha_seq_l <- seq(lower_alpha, 1, length.out = length / 2) 139 | alpha_seq_l <- alpha_seq_l[-length(alpha_seq_l)] 140 | alpha_seq_u <- rev(1 / alpha_seq_l) 141 | } else { 142 | alpha_seq_u <- seq(1, upper_alpha, length.out = length / 2) 143 | alpha_seq_u <- alpha_seq_u[-1] 144 | alpha_seq_l <- rev(1 / alpha_seq_u) 145 | } 146 | alpha_seq <- c(alpha_seq_l, alpha_seq_u) 147 | } 148 | 149 | variable_base <- variable 150 | # compute predictions (necessary at this place to infer the variable names 151 | # from the predictions in the next step) 152 | if (!is.null(prediction)) { 153 | pred_draws <- prediction(x$fit, ...) 154 | } 155 | # for retrieving the base draws, we need to exclude the variable names from 156 | # the predictions 157 | # TODO: this step might be necessary at other places in the package as well 158 | if (!is.null(prediction) && !is.null(variable_base)) { 159 | variable_base <- setdiff(variable_base, posterior::variables(pred_draws)) 160 | } 161 | # extract the base draws 162 | base_draws <- posterior::subset_draws( 163 | x$draws, 164 | variable = variable_base, 165 | ...) 166 | # append predictions 167 | if (!is.null(prediction)) { 168 | base_draws <- posterior::bind_draws(base_draws, pred_draws) 169 | } 170 | 171 | if (is.null(transform)) { 172 | transform <- "identity" 173 | } 174 | if (transform == "whiten") { 175 | base_draws_tr <- whiten_draws(base_draws, ...) 176 | transform_details <- list( 177 | transform = transform, 178 | loadings = attr(base_draws_tr, "loadings") 179 | ) 180 | base_draws <- base_draws_tr 181 | } else if (transform == "scale") { 182 | base_draws <- scale_draws(base_draws, ...) 183 | transform_details <- list(transform = transform) 184 | } else { 185 | transform_details <- list(transform = transform) 186 | } 187 | 188 | 189 | 190 | scaled_draws_list <- vector("list", length(alpha_seq)) 191 | 192 | likelihood_scaled <- NULL 193 | prior_scaled <- NULL 194 | 195 | if ("prior" %in% component) { 196 | 197 | scaled_component <- "prior" 198 | 199 | for (i in seq_along(alpha_seq)) { 200 | 201 | # skip alpha = 1 202 | if (alpha_seq[i] == 1) { 203 | next 204 | } 205 | 206 | # calculate the scaled draws 207 | scaled_draws_list[[i]] <- powerscale( 208 | x = x, 209 | variable = variable, 210 | component = scaled_component, 211 | alpha = alpha_seq[i], 212 | moment_match = moment_match, 213 | k_threshold = k_threshold, 214 | resample = resample, 215 | transform = transform, 216 | prediction = prediction, 217 | selection = prior_selection, 218 | ... 219 | ) 220 | } 221 | 222 | prior_scaled <- list( 223 | draws_sequence = scaled_draws_list, 224 | component = scaled_component 225 | ) 226 | } 227 | if ("likelihood" %in% component) { 228 | 229 | scaled_component <- "likelihood" 230 | 231 | for (i in seq_along(alpha_seq)) { 232 | 233 | # skip alpha = 1 234 | if (alpha_seq[i] == 1) { 235 | next 236 | } 237 | 238 | # calculate the scaled draws 239 | scaled_draws_list[[i]] <- powerscale( 240 | x = x, 241 | variable = variable, 242 | component = scaled_component, 243 | alpha = alpha_seq[i], 244 | moment_match = moment_match, 245 | k_threshold = k_threshold, 246 | resample = resample, 247 | transform = transform, 248 | prediction = prediction, 249 | selection = likelihood_selection, 250 | ... 251 | ) 252 | 253 | } 254 | 255 | likelihood_scaled <- list( 256 | draws_sequence = scaled_draws_list, 257 | component = scaled_component 258 | ) 259 | 260 | } 261 | 262 | out <- list( 263 | base_draws = base_draws, 264 | prior_scaled = prior_scaled, 265 | likelihood_scaled = likelihood_scaled, 266 | alphas = alpha_seq, 267 | moment_match = moment_match, 268 | resampled = resample, 269 | transform = transform_details 270 | ) 271 | 272 | class(out) <- c("powerscaled_sequence", class(out)) 273 | 274 | return(out) 275 | 276 | } 277 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | ##' @srrstats{EA4.2} print method implemented 2 | ##' @srrstats {EA5.2} rounding used for digit display 3 | ##' @export 4 | print.powerscaling_details <- function(x, ...) { 5 | 6 | pareto_k <- x$diagnostics$khat 7 | pareto_k_threshold <- x$diagnostics$khat_threshold 8 | pareto_kf <- x$diagnostics$khatf 9 | 10 | pareto_k_print <- c() 11 | 12 | pareto_k_print <- paste("pareto-k:", round(pareto_k, digits = 2), "\n") 13 | 14 | if (!is.null(pareto_kf)) { 15 | pareto_k_print <- c( 16 | "moment-matched\n", 17 | pareto_k_print, 18 | paste("pareto-kf", 19 | round(pareto_kf, digits = 2), 20 | "\n") 21 | ) 22 | } 23 | 24 | cat( 25 | "\npower-scaling\n", 26 | paste("alpha:", x$alpha, "\n"), 27 | paste("scaled component:", x$component, "\n"), 28 | "selection:", x$selection, "\n", 29 | pareto_k_print, 30 | paste("pareto-k threshold:", round(pareto_k_threshold, 2), "\n"), 31 | paste("resampled:", x$resampled, "\n"), 32 | paste("transform:", x$transform_details$transform, "\n") 33 | ) 34 | 35 | invisible(x) 36 | } 37 | 38 | ##' @export 39 | print.powerscaled_draws <- function(x, ...) { 40 | NextMethod(...) 41 | print(attr(x, "powerscaling"), ...) 42 | 43 | invisible(x) 44 | } 45 | 46 | ##' @export 47 | print.powerscaled_draws_summary <- function(x, ...) { 48 | NextMethod() 49 | print(get_powerscaling_details(x)) 50 | 51 | invisible(x) 52 | } 53 | 54 | ##' @export 55 | print.powerscaled_sequence <- function(x, ...) { 56 | 57 | component <- c() 58 | if (!is.null(x$prior_scaled)) { 59 | component <- c("prior", component) 60 | } 61 | 62 | if (!is.null(x$likelihood_scaled)) { 63 | component <- c("likelihood", component) 64 | } 65 | 66 | cat("base draws:\n") 67 | print(x$base_draws, ...) 68 | 69 | cat( 70 | "\npower-scaling\n", 71 | paste0("alpha range: [", min(x$alphas), ", ", max(x$alphas), "]\n"), 72 | paste("length of sequence:", length(x$alphas), "\n"), 73 | paste("scaled component:", component, "\n"), 74 | paste("transform:", x$transform$transform, "\n") 75 | ) 76 | 77 | invisible(x) 78 | } 79 | 80 | 81 | ##' @export 82 | print.powerscaled_sensitivity_summary <- function(x, digits = 3, ...) { 83 | 84 | cat(paste0("Sensitivity based on ", attr(x, "div_measure"), "\n")) 85 | cat(paste0("Prior selection: ", ifelse(is.null(attr(x, "prior_selection")), "all priors", paste0(attr(x, "prior_selection"), collapse = ", ")), "\n")) 86 | cat(paste0("Likelihood selection: ", ifelse(is.null(attr(x, "likelihood_selection")), "all data", paste0(attr(x, "likelihood_selection"), collapse = ", ")), "\n")) 87 | cat("\n") 88 | print.data.frame( 89 | as.data.frame( 90 | lapply(x, function(c) if (is.numeric(c)) round(c, digits) else c) 91 | ), 92 | row.names = FALSE 93 | ) 94 | 95 | if (!is.null(attr(x, "loadings"))) { 96 | cat("Factor loadings:\n") 97 | print(round(attr(x, "loadings"), digits = digits)) 98 | } 99 | invisible(x) 100 | } 101 | 102 | 103 | ##' @export 104 | print.whitened_draws <- function(x, ...) { 105 | NextMethod() 106 | cat("Factor loadings:\n") 107 | print(attr(x, "loadings"), ...) 108 | invisible(x) 109 | 110 | } 111 | 112 | ##' @export 113 | print.whitened_draws_summary <- function(x, ...) { 114 | NextMethod() 115 | cat("Factor loadings:\n") 116 | print(attr(x, "loadings"), ...) 117 | invisible(x) 118 | 119 | } 120 | -------------------------------------------------------------------------------- /R/priorsense-package.R: -------------------------------------------------------------------------------- 1 | #' priorsense: Prior (and likelihood) diagnostics and sensitivity 2 | #' analysis 3 | #' 4 | #' @name priorsense-package 5 | #' @aliases priorsense 6 | #' @importFrom posterior summarise_draws 7 | #' 8 | #' @description The \pkg{priorsense} package provides functions for 9 | #' prior and likelihood sensitivity analysis of Bayesian 10 | #' models. Currently it implements methods to determine the 11 | #' sensitivity of the posterior to power-scaling perturbations of 12 | #' the prior and likelihood and is the first implementation of the 13 | #' method described in Kallioinen et al. (2023). 14 | #' 15 | #' 16 | #' 17 | #' @details The main diagnostic function provided by \pkg{priorsense} 18 | #' is \code{\link{powerscale_sensitivity}}. Given a fitted model or 19 | #' draws object, it computes the powerscaling sensitivity diagnostic 20 | #' described in Kallioinen et al. (2023). It does so by perturbing 21 | #' the prior and likelihood and computing the effect on the 22 | #' posterior, without needing to refit the model (using Pareto 23 | #' smoothed importance sampling and importance weighted moment 24 | #' matching; Vehtari et al. 2022, Paananen et al. 2021). 25 | #' 26 | #' In addition, visual diagnostics are available by first using 27 | #' \code{\link{powerscale_sequence}} to create a sequence of perturbed 28 | #' posteriors, and then a plot function such as 29 | #' \code{\link{powerscale_plot_ecdf}} to visualise the change. 30 | #' 31 | #' The following global options are available: 32 | #' * `priorsense.plot_help_text`: If `TRUE` (the default), priorsense plots will include a title and explanatory text. If `FALSE` they will not. 33 | #' * `priorsense.plot_variables_per_page`: Number specifying the maximum number of variables to be plotted on one page of a plot. 34 | #' * `priorsense.plot_ask`: If `TRUE` (the default), when multiple pages are plotted input is required before each subsequent page is rendered. 35 | #' If `FALSE` no input is required. 36 | #' 37 | #' @srrstats {G1.0} primary references are cited 38 | #' @srrstats {G1.1} specified above that it is the first implementation 39 | #' @srrstats {G1.3} vignettes, documentation and linked papers explain 40 | #' statistical terminology 41 | #' @srrstats {G1.4} All functions are documented with roxygen2 42 | #' @srrstats {G1.2} Lifecycle statement is in the file CONTRIBUTING.md 43 | #' @srrstats {G1.4a} All internal (non-exported) functions are 44 | #' documneted with roxygen2 along with a final `@noRd` tag 45 | #' @srrstats {G2.10} Tabular inputs are converted to 46 | #' `posterior::draws` objects and subsetting is handled through 47 | #' `posterior` functions 48 | #' @srrstats {EA1.0, EA1.1, EA1.2} target audience, data type and 49 | #' target questions specified in README and vignette 50 | #' @srrstats {EA1.3} input types of each function are specified in 51 | #' documentation 52 | #' @srrstats {EA2.0, EA2.1, EA2.2, EA2.2a, EA2.2b, EA2.3, EA2.4, 53 | #' EA2.5} priorsense relies on the `posterior` package for tabular data 54 | #' @srrstats {EA3.1} priorsense provides diagnostic value which is 55 | #' automatically calculated rather than based on unstandardized ad 56 | #' hoc sensitivity analysis 57 | #' @srrstats {EA5.3} column summaries are handled by `posterior` package 58 | 59 | 60 | 61 | 62 | #' @seealso 63 | #' \code{\link{powerscale_sensitivity}} 64 | #' \code{\link{powerscale_sequence}} 65 | #' \code{\link{powerscale}} 66 | #' \code{\link{powerscale_plot_ecdf}} 67 | #' \code{\link{powerscale_plot_dens}} 68 | #' \code{\link{powerscale_plot_quantities}} 69 | #' @template powerscale_references 70 | "_PACKAGE" 71 | 72 | 73 | ## usethis namespace: start 74 | ##' @importFrom lifecycle deprecated 75 | ##' ## usethis namespace: end 76 | #' NULL 77 | -------------------------------------------------------------------------------- /R/scale_draws.R: -------------------------------------------------------------------------------- 1 | ##' scale draws 2 | ##' @param draws draws object 3 | ##' @param center boolean flag indicating whether or not to center 4 | ##' draws 5 | ##' @param scale boolean flag indicating whether or not to scale draws 6 | ##' by standard deviation 7 | ##' @param ... unused 8 | ##' @return draws object with variables centered and/or scaled 9 | ##' @noRd 10 | scale_draws <- function(draws, center = TRUE, scale = TRUE, ...) { 11 | 12 | draws <- posterior::as_draws_matrix(draws) 13 | 14 | # keep track of weights 15 | wei <- stats::weights(draws) 16 | 17 | # remove weights 18 | if (!(is.null(wei))) { 19 | base_draws <- posterior::mutate_variables( 20 | base_draws, 21 | .log_weight = NULL) 22 | } 23 | 24 | # center draws 25 | if (center) { 26 | center <- matrixStats::colMedians(draws) 27 | } 28 | if (scale) { 29 | scale <- matrixStats::colMads(draws) 30 | } 31 | draws_c <- base::scale(draws, center = center, scale = scale) 32 | 33 | # add weights column back 34 | if (!(is.null(wei))) { 35 | draws_c <- posterior::weight_draws(draws_c, wei) 36 | } 37 | 38 | draws_c <- posterior::as_draws_df(draws_c) 39 | 40 | return(draws_c) 41 | } 42 | -------------------------------------------------------------------------------- /R/scaled_log_ratio.R: -------------------------------------------------------------------------------- 1 | ##' Calculate importance ratios based on scaling of component 2 | ##' 3 | ##' @param component_draws draws from component to powerscale 4 | ##' @param alpha scaling factor 5 | ##' @param ... unused 6 | ##' @return log ratio 7 | ##' @keywords internal 8 | ##' @noRd 9 | scaled_log_ratio <- function(component_draws, alpha, 10 | ...) { 11 | 12 | # calculate log ratios for power-scaling 13 | scaled <- component_draws * (alpha - 1) 14 | 15 | return(scaled) 16 | } 17 | 18 | # Density ratio function for moment matching 19 | ##' @param draws draws object 20 | ##' @param fit fit object that will be passed to `iwmm::constrain_draws` 21 | ##' @param alpha power-scaling alpha value 22 | ##' @param component_fn function to extract log component from constrained draws 23 | ##' @param ... unused 24 | ##' @return vector of density ratio 25 | ##' @keywords internal 26 | ##' @noRd 27 | powerscale_log_ratio_fun <- function(draws, fit, alpha, component_fn, ...) { 28 | 29 | constr_draws <- iwmm::constrain_draws(fit, draws) 30 | 31 | component_draws <- rowsums_draws(component_fn(constr_draws)) 32 | 33 | component_draws * (alpha - 1) 34 | 35 | } 36 | -------------------------------------------------------------------------------- /R/srr-stats-standards.R: -------------------------------------------------------------------------------- 1 | #' srr_stats 2 | #' 3 | #' All of the following standards initially have `@srrstatsTODO` tags. 4 | #' These may be moved at any time to any other locations in your code. 5 | #' Once addressed, please modify the tag from `@srrstatsTODO` to `@srrstats`, 6 | #' or `@srrstatsNA`, ensuring that references to every one of the following 7 | #' standards remain somewhere within your code. 8 | #' (These comments may be deleted at any time.) 9 | #' 10 | #' @srrstatsVerbose TRUE 11 | #' 12 | #' 13 | #' 14 | #' 15 | #' 16 | #' @noRd 17 | NULL 18 | 19 | #' NA_standards 20 | #' 21 | #' Any non-applicable standards can have their tags changed from 22 | #' `@srrstatsTODO` to `@srrstatsNA`, and placed together in this 23 | #' block, along with explanations for why each of these standards have 24 | #' been deemed not applicable. (These comments may also be deleted at 25 | #' any time.) 26 | #' @srrstatsNA {G1.5} No performance claims are made about this 27 | #' software 28 | #' @srrstatsNA {G1.6} There are no other implementations of this 29 | #' method in R packages. 30 | #' @srrstatsNA {G2.4a} No conversion to integers required. 31 | #' @srrstatsNA {G2.4d} *explicit conversion to factor via 32 | #' `as.factor()`* 33 | #' @srrstatsNA {G2.5} No functions require factor type inputs. 34 | #' @srrstatsNA {G2.9} posterior package is used for type conversion of 35 | #' draws objects, and has warnings for loss of information. 36 | #' @srrstatsNA {G2.11} The `posterior` package is used to handle 37 | #' tabular data. 38 | #' @srrstatsNA {G2.14b, G2.14c} Missing values result in error, or are 39 | #' handled by `posterior` package. 40 | #' @srrstatsNA {G4.0} No files are written by priorsense. 41 | #' @srrstatsNA {G5.4} priorsense is the first implementation. 42 | #' @srrstatsNA {G5.4b} priorsense is the first implementation. 43 | #' @srrstatsNA {G5.4c} priorsense is the first implementation. 44 | #' @srrstatsNA {G5.10, G5.12} There are no extended tests in 45 | #' priorsense. 46 | #' @srrstatsNA {G5.11} No downloads are required for tests. 47 | #' @srrstatsNA {G5.11a} No downloads are required for tests. 48 | #' @srrstatsNA {G2.12} tabular objects are handled via the `posterior` 49 | #' package 50 | #' 51 | #' @srrstatsNA {EA5.6} No bundled libraries 52 | #' @srrstatsNA {EA5.6} No bundled libraries 53 | #' @srrstatsNA {EA5.5} plots do not require units as they are unit-free quantities 54 | #' @srrstatsNA {EA5.1} default typefaces are used 55 | #' 56 | #' @noRd 57 | NULL 58 | -------------------------------------------------------------------------------- /R/summarise_draws.R: -------------------------------------------------------------------------------- 1 | ##' Summarise draws 2 | ##' 3 | ##' Summarise power-scaled draws 4 | ##' @param .x An object of class powerscaled_draws 5 | ##' @param ... summary functions 6 | ##' @param .args arguments for summary functions 7 | ##' @param .num_args (named list) Optional arguments passed to 8 | ##' [num()][tibble::num] for pretty printing of summaries. Can be 9 | ##' controlled globally via the `posterior.num_args` 10 | ##' [option][base::options]. 11 | ##' @param base_draws base draws 12 | ##' @param diagnostics boolean, if TRUE include diagnostics for mean 13 | ##' and variance 14 | ##' @param div_measures divergence measures 15 | ##' @param measure_args arguments for divergence measures 16 | ##' @param resample resample draws 17 | ##' @noRd 18 | ##' @exportS3Method posterior::summarise_draws 19 | summarise_draws.powerscaled_draws <- function(.x, 20 | ..., 21 | .num_args = NULL, 22 | .args = list(), 23 | base_draws = NULL, 24 | diagnostics = FALSE, 25 | div_measures = "cjs_dist", 26 | measure_args = list(), 27 | resample = FALSE) { 28 | 29 | funs <- c(...) 30 | if (length(funs) == 0) { 31 | funs <- posterior::default_summary_measures() 32 | } 33 | 34 | ps_details <- get_powerscaling_details(.x) 35 | 36 | .args <- as.list(.args) 37 | 38 | if (resample && !ps_details$resampled) { 39 | # only resample if specified and draws are not already resampled 40 | target_draws <- posterior::resample_draws( 41 | posterior::merge_chains(.x) 42 | ) 43 | } else { 44 | target_draws <- .x 45 | } 46 | 47 | if (!resample && !ps_details$resampled) { 48 | # without resampling, only weighted quantities used 49 | funs <- as.list( 50 | paste0(funs, "_weighted") 51 | ) 52 | 53 | # add the weights to args 54 | .args <- c( 55 | list(weights = stats::weights(.x)), 56 | .args 57 | ) 58 | } 59 | 60 | class(target_draws) <- class(target_draws)[-1] 61 | 62 | summ <- posterior::summarise_draws( 63 | .x = target_draws, 64 | ... = funs, 65 | .args = .args, 66 | .num_args = .num_args 67 | ) 68 | 69 | 70 | if (!is.null(base_draws)) { 71 | # calculate the divergences between the base and target draws 72 | divergences <- measure_divergence( 73 | draws1 = posterior::merge_chains(base_draws), 74 | draws2 = posterior::merge_chains(target_draws), 75 | measure = div_measures, 76 | measure_args = measure_args 77 | ) 78 | 79 | summ <- merge(summ, divergences, by = "variable") 80 | } 81 | 82 | out <- summ 83 | 84 | if (resample) { 85 | ps_details$resampled <- TRUE 86 | } 87 | 88 | attr(out, "powerscaling") <- ps_details 89 | 90 | 91 | class(out) <- c("powerscaled_draws_summary", class(out)) 92 | return(out) 93 | } 94 | 95 | ##' Summarise draws 96 | ##' 97 | ##' @param .x powerscaled_sequence 98 | ##' @param ... summary functions 99 | ##' @param .args additional arguments to summary functions 100 | ##' @param .num_args (named list) Optional arguments passed to 101 | ##' [num()][tibble::num] for pretty printing of summaries. Can be 102 | ##' controlled globally via the `posterior.num_args` 103 | ##' [option][base::options]. 104 | ##' @param div_measures divergence measures 105 | ##' @param measure_args arguments for divergence measures 106 | ##' @param resample resample 107 | ##' @return powerscaled_sequence_summary 108 | ##' @srrstats{EA4.2} summary method implemented 109 | ##' @noRd 110 | ##' @exportS3Method posterior::summarise_draws 111 | summarise_draws.powerscaled_sequence <- function(.x, 112 | ..., 113 | .args = list(), 114 | .num_args = NULL, 115 | div_measures = "cjs_dist", 116 | measure_args = list(), 117 | resample = FALSE) { 118 | # handle quantity functions 119 | funs <- unname(c(...)) 120 | # use default functions if unspecified 121 | if (length(funs) == 0) { 122 | funs <- posterior::default_summary_measures() 123 | } 124 | 125 | # extract base draws 126 | base_draws <- .x$base_draws 127 | 128 | # create summaries for all power-scaled posteriors 129 | summaries <- data.frame() 130 | 131 | # for base posterior 132 | base_quantities <- posterior::summarise_draws( 133 | .x = posterior::merge_chains(base_draws), 134 | funs, 135 | .args = .args, 136 | .num_args = .num_args 137 | ) 138 | 139 | base_quantities[[".powerscale_alpha"]] <- 1 140 | base_quantities$pareto_k_threshold <- Inf 141 | base_quantities$pareto_k <- -Inf 142 | 143 | base_distance <- measure_divergence( 144 | draws1 = posterior::merge_chains(base_draws), 145 | draws2 = posterior::merge_chains(base_draws), 146 | measure = div_measures, 147 | measure_args = measure_args 148 | ) 149 | 150 | base_summary <- merge( 151 | x = base_quantities, 152 | y = base_distance, 153 | by = "variable" 154 | ) 155 | 156 | base_summary_prior <- c() 157 | base_summary_likelihood <- c() 158 | 159 | # for prior-scaled 160 | if (!is.null(.x$prior_scaled)) { 161 | 162 | base_summary_prior <- base_summary 163 | base_summary_prior$component <- "prior" 164 | 165 | # loop over and summarise set of power-scaled posteriors 166 | for (scaled in .x$prior_scaled$draws_sequence) { 167 | 168 | quantities <- summarise_draws( 169 | .x = scaled, 170 | ... = funs, 171 | .args = .args, 172 | base_draws = base_draws, 173 | div_measures = div_measures, 174 | resample = resample 175 | ) 176 | 177 | ps_details <- get_powerscaling_details(quantities) 178 | 179 | quantities[[".powerscale_alpha"]] <- ps_details$alpha 180 | quantities$component <- ps_details$component 181 | quantities$pareto_k <- ps_details$diagnostics$khat 182 | quantities$pareto_k_threshold <- ps_details$diagnostics$khat_threshold 183 | 184 | summaries <- rbind(summaries, quantities) 185 | } 186 | } 187 | 188 | # for likelihood-scaled 189 | if (!is.null(.x$likelihood_scaled)) { 190 | 191 | base_summary_likelihood <- base_summary 192 | base_summary_likelihood$component <- "likelihood" 193 | 194 | # loop over and summarise set of power-scaled posteriors 195 | for (scaled in .x$likelihood_scaled$draws_sequence) { 196 | 197 | quantities <- summarise_draws( 198 | .x = scaled, 199 | funs, 200 | .args = .args, 201 | base_draws = base_draws, 202 | div_measures = div_measures, 203 | resample = resample 204 | ) 205 | 206 | ps_details <- get_powerscaling_details(quantities) 207 | 208 | quantities[[".powerscale_alpha"]] <- ps_details$alpha 209 | quantities$component <- ps_details$component 210 | quantities$pareto_k <- ps_details$diagnostics$khat 211 | quantities$pareto_k_threshold <- ps_details$diagnostics$khat_threshold 212 | 213 | summaries <- rbind(summaries, quantities) 214 | } 215 | } 216 | 217 | # join base and perturbed summaries 218 | summaries <- list( 219 | rbind( 220 | base_summary_prior, 221 | base_summary_likelihood, 222 | summaries) 223 | ) 224 | 225 | # correctly specify types of variables 226 | summaries[[1]][["component"]] <- factor( 227 | summaries[[1]][["component"]], 228 | levels = c("prior", "likelihood") 229 | ) 230 | 231 | class(summaries) <- c("powerscaled_sequence_summary", class(summaries)) 232 | 233 | return(summaries) 234 | } 235 | 236 | ##' @export 237 | summarise_draws.whitened_draws <- function(.x, ...) { 238 | class(.x) <- class(.x)[-1] 239 | summary <- posterior::summarise_draws(.x, ...) 240 | attr(summary, "loadings") <- attr(.x, "loadings") 241 | class(summary) <- c("whitened_draws_summary", class(summary)) 242 | return(summary) 243 | } 244 | -------------------------------------------------------------------------------- /R/sysdata.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/n-kall/priorsense/c482f522d399dcc23cdee541c2e96098f044aef9/R/sysdata.rda -------------------------------------------------------------------------------- /R/weighted_diagnostics.R: -------------------------------------------------------------------------------- 1 | ##' Importance sampling effective sample size diagnostic for 2 | ##' computing the mean of a parameter 3 | ##' @param x vector of values 4 | ##' @param log_ratios vector of standard importance sampling weights 5 | ##' @param ... unused 6 | ##' @return numeric 7 | ##' @noRd 8 | ess_mean <- function(x, log_ratios, ...) { 9 | lwf_mean <- c(log(log_ratios) + log(abs(x))) 10 | lwf_mean <- lwf_mean - matrixStats::logSumExp(lwf_mean) 11 | ess <- 1.0 / sum(exp(2 * lwf_mean)) 12 | 13 | return(c(ess_mean = ess)) 14 | } 15 | 16 | ##' Importance sampling effective sample size diagnostic for 17 | ##' computing the variance of a parameter 18 | ##' @param x vector of values 19 | ##' @param log_ratios vector of standard importance sampling weights 20 | ##' @param ... unused 21 | ##' @return numeric 22 | ##' @noRd 23 | ess_var <- function(x, log_ratios, ...) { 24 | lwf_var <- c(log(log_ratios) + log(abs(x^2))) 25 | lwf_var <- lwf_var - matrixStats::logSumExp(lwf_var) 26 | ess <- 1.0 / sum(exp(2 * lwf_var)) 27 | 28 | return(c(ess_var = ess)) 29 | } 30 | 31 | ##' Pareto-k diagnostic for computing the mean of a parameter 32 | ##' @param x vector of values 33 | ##' @param log_ratios vector of standard importance sampling weights 34 | ##' @param ... unused 35 | ##' @return numeric 36 | ##' @noRd 37 | pareto_k_mean <- function(x, log_ratios, ...) { 38 | pareto_k_mean <- posterior::pareto_khat( 39 | x = c(log(log_ratios) + log(abs(x))), 40 | are_log_weights = TRUE 41 | ) 42 | return(c(pareto_k_mean = pareto_k_mean)) 43 | } 44 | 45 | ##' Pareto-k diagnostic for computing the variance of a parameter 46 | ##' @param x vector of values 47 | ##' @param log_ratios vector of standard importance sampling weights 48 | ##' @param ... unused 49 | ##' @return numeric 50 | ##' @noRd 51 | pareto_k_var <- function(x, log_ratios, ...) { 52 | pareto_k_var <- posterior::pareto_khat( 53 | x = c(log(log_ratios) + log(abs(x^2))), 54 | are_log_weights = TRUE 55 | ) 56 | return(c(pareto_k_var = pareto_k_var)) 57 | } 58 | -------------------------------------------------------------------------------- /R/weighted_quantities.R: -------------------------------------------------------------------------------- 1 | ##' Weighted quantities 2 | ##' 3 | ##' Weighted version of common quantities of interest. 4 | ##' 5 | ##' @param x Numeric vector to calculate quantity from. 6 | ##' @param weights Vector of weights corresponding to values in x. 7 | ##' @param probs Vector of probabilities for quantiles. 8 | ##' @param type Character vector specifying type of quantiles (either 9 | ##' "7" for Type 7 (default) or "hd" for Harrell-Davis) 10 | ##' @param ... Currently unused. 11 | ##' @return Named vector of calculated quantity. 12 | ##' @name weighted_quantities 13 | ##' @keywords internal 14 | ##' @srrstats {G2.14, G2.14a, G2.15} weighted quantities specified to 15 | ##' error on missing data, as this should not occur 16 | ##' @srrstats {G2.6} Inputs to these internal functions are 1-d draws 17 | ##' objects 18 | ##' @noRd 19 | NULL 20 | 21 | median_weighted <- function(x, weights, ...) { 22 | 23 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) 24 | 25 | checkmate::assert_numeric(weights, len = length(x), 26 | null.ok = TRUE, any.missing = FALSE) 27 | 28 | x <- as.numeric(x) 29 | weights <- as.numeric(weights) 30 | 31 | weighted_median <- matrixStats::weightedMedian( 32 | x = x, 33 | w = weights 34 | ) 35 | 36 | return(c(median = weighted_median)) 37 | } 38 | 39 | mad_weighted <- function(x, weights, ...) { 40 | 41 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) 42 | 43 | checkmate::assert_numeric(weights, len = length(x), 44 | null.ok = TRUE, any.missing = FALSE) 45 | 46 | x <- as.numeric(x) 47 | weights <- as.numeric(weights) 48 | 49 | weighted_mad <- matrixStats::weightedMad( 50 | x = x, 51 | w = weights 52 | ) 53 | 54 | return(c(mad = weighted_mad)) 55 | } 56 | 57 | var_weighted <- function(x, weights, ...) { 58 | 59 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) 60 | 61 | checkmate::assert_numeric(weights, len = length(x), null.ok = TRUE, 62 | any.missing = FALSE) 63 | 64 | x <- as.numeric(x) 65 | weights <- as.numeric(weights) 66 | 67 | if (is.null(weights)) { 68 | var <- var(x) 69 | } else { 70 | var <- as.numeric(stats::cov.wt(cbind(as.numeric(x)), weights)$cov) 71 | } 72 | return(c(var = var)) 73 | } 74 | 75 | sd_weighted <- function(x, weights, ...) { 76 | 77 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) 78 | 79 | checkmate::assert_numeric(weights, len = length(x), null.ok = TRUE, 80 | any.missing = FALSE) 81 | 82 | x <- as.numeric(x) 83 | weights <- as.numeric(weights) 84 | 85 | if (is.null(weights)) { 86 | sd <- sd(x) 87 | } else { 88 | sd <- as.numeric(sqrt(var_weighted(x, weights))) 89 | } 90 | return(c(sd = sd)) 91 | } 92 | 93 | mean_weighted <- function(x, weights, ...) { 94 | 95 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) 96 | 97 | checkmate::assert_numeric(weights, len = length(x), null.ok = TRUE, 98 | any.missing = FALSE) 99 | 100 | x <- as.numeric(x) 101 | weights <- as.numeric(weights) 102 | 103 | weighted_mean <- matrixStats::weightedMean( 104 | x = x, 105 | w = weights 106 | ) 107 | 108 | return(c(mean = weighted_mean)) 109 | } 110 | 111 | ##' Weighted summary measures 112 | ##' 113 | ##' Returns weighted versions of 114 | ##' `posterior::default_summary_measures()` to be used with 115 | ##' `posterior::summarise_draws()`. 116 | ##' @param x draws object to extract weights from 117 | ##' @return Vector of formulas for use with 118 | ##' `posterior::summarise_draws()` 119 | ##' @keywords internal 120 | ##' @noRd 121 | weighted_summary_measures <- function(x) { 122 | funcs <- c( 123 | stats::as.formula(paste0("~mean_weighted(.x, weights(", x, "))")), 124 | stats::as.formula(paste0("~median_weighted(.x, weights(", x, "))")), 125 | stats::as.formula(paste0("~sd_weighted(.x, weights(", x, "))")), 126 | stats::as.formula(paste0("~mad_weighted(.x, weights(", x, "))")), 127 | stats::as.formula(paste0("~quantile_weighted(.x, weights(", x, "))")) 128 | ) 129 | return(funcs) 130 | } 131 | 132 | quantile_weighted <- function(x, weights, probs = c(0.05, 0.95), 133 | type = "7", ...) { 134 | 135 | checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) 136 | checkmate::assert_numeric(weights, len = length(x), null.ok = TRUE, 137 | any.missing = FALSE) 138 | 139 | checkmate::assert_numeric(probs, null.ok = FALSE, any.missing = FALSE) 140 | 141 | checkmate::assert_choice(type, c("7", "hd"), null.ok = FALSE) 142 | 143 | ## Following is adapted from Andrey Akinshin (2023) "Weighted 144 | ## quantile estimators" arXiv:2304.07265 [stat.ME] 145 | if (type == "7") { 146 | # Weighted Type 7 quantile estimator 147 | cdf_fun <- function(n, p) { 148 | return(function(cdf_probs) { 149 | h <- p * (n - 1) + 1 150 | u <- pmax((h - 1) / n, pmin(h / n, cdf_probs)) 151 | u * n - h + 1 152 | }) 153 | } 154 | } else if (type == "hd") { 155 | # Weighted Harrell-Davis quantile estimator 156 | cdf_fun <- function(n, p) { 157 | return(function(cdf_probs) { 158 | stats::pbeta(cdf_probs, (n + 1) * p, (n + 1) * (1 - p)) 159 | }) 160 | } 161 | } 162 | quants <- .quantile_weighted( 163 | x = x, 164 | weights = weights, 165 | probs = probs, 166 | cdf_fun = cdf_fun 167 | ) 168 | names(quants) <- paste0("q", probs * 100) 169 | return(quants) 170 | } 171 | ##' calculation of weighted quantile 172 | ##' @param x numeric vector of draws 173 | ##' @param probs numeric vector specifying probabilities 174 | ##' @param cdf_fun cumulative distribution function 175 | ##' @param weights numeric vector of weights 176 | ##' @param type type of quantile calculation 177 | ##' @param ... unused 178 | ##' @return vector of quantiles 179 | ##' @noRd 180 | .quantile_weighted <- function(x, probs, cdf_fun, weights) { 181 | # Weighted generic quantile estimator 182 | n <- length(x) 183 | if (is.null(weights)) 184 | weights <- rep(1 / n, n) 185 | nw <- sum(weights)^2 / sum(weights^2) # Kish's effective sample size 186 | 187 | idx <- order(x) 188 | x <- x[idx] 189 | weights <- weights[idx] 190 | 191 | weights <- weights / sum(weights) 192 | cdf_probs <- cumsum(c(0, weights)) 193 | 194 | vapply(probs, 195 | function(p) { 196 | cdf <- cdf_fun(nw, p) 197 | q <- cdf(cdf_probs) 198 | w <- utils::tail(q, -1) - utils::head(q, -1) 199 | sum(w * x) 200 | }, 201 | FUN.VALUE = c(1)) 202 | } 203 | 204 | quantile2_weighted <- quantile_weighted 205 | 206 | # always use quantile2 internally 207 | quantile <- posterior::quantile2 208 | -------------------------------------------------------------------------------- /R/whiten_draws.R: -------------------------------------------------------------------------------- 1 | ##' Transform draws to be spherical 2 | ##' @param draws draws to be transformed 3 | ##' @param covariance_fn function used to compute covariance 4 | ##' @param ... unused 5 | ##' @return transformed draws 6 | ##' @srrstats {G3.1, G3.1a} Function for computing covariance can be specified 7 | ##' @noRd 8 | whiten_draws <- function(draws, covariance_fn = stats::cov, ...) { 9 | 10 | base_draws <- posterior::as_draws_matrix( 11 | posterior::merge_chains(draws) 12 | ) 13 | 14 | # keep track of weights 15 | wei <- stats::weights(base_draws) 16 | 17 | # remove weights 18 | if (!(is.null(wei))) { 19 | base_draws <- posterior::mutate_variables( 20 | base_draws, 21 | .log_weight = NULL) 22 | } 23 | 24 | # code from whitening package (c) Korbinian Strimmer and Takoua 25 | # Jendoubi and Agnan Kessy and Alex Lewin 26 | Sigma <- covariance_fn(base_draws) 27 | v <- diag(Sigma) 28 | R <- stats::cov2cor(Sigma) 29 | eR <- eigen(R, symmetric = TRUE) 30 | G <- eR$vectors 31 | theta <- eR$values 32 | G <- sweep(G, 2, sign(diag(G)), "*") 33 | W <- diag(1 / sqrt(theta)) %*% t(G) %*% diag(1 / sqrt(v)) 34 | draws_tr <- tcrossprod(base_draws, W) 35 | draws_tr <- sweep(draws_tr, 2, colMeans(draws_tr)) 36 | 37 | loadings <- G 38 | 39 | # cleanup transformed draws 40 | draws_tr <- posterior::as_draws_df(draws_tr) 41 | posterior::variables(draws_tr) <- paste0( 42 | "C", 43 | 1:posterior::nvariables(draws_tr) 44 | ) 45 | 46 | # add weights column back 47 | if (!(is.null(wei))) { 48 | draws_tr <- posterior::weight_draws(draws_tr, wei) 49 | } 50 | 51 | colnames(loadings) <- posterior::variables(draws_tr) 52 | rownames(loadings) <- posterior::variables(base_draws) 53 | 54 | attr(draws_tr, "loadings") <- t(loadings) 55 | 56 | class(draws_tr) <- c("whitened_draws", class(draws_tr)) 57 | 58 | return(draws_tr) 59 | } 60 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # priorsense 2 | 3 | 4 | 5 | 6 | 7 | 8 | [![Lifecycle: 9 | stable](https://img.shields.io/badge/lifecycle-stable-green.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) 10 | [![CRAN 11 | status](https://www.r-pkg.org/badges/version/priorsense)](https://CRAN.R-project.org/package=priorsense) 12 | [![R-CMD-check](https://github.com/n-kall/priorsense/workflows/R-CMD-check/badge.svg)](https://github.com/n-kall/priorsense/actions) 13 | 14 | 15 | ## Overview 16 | 17 | priorsense provides tools for prior diagnostics and sensitivity 18 | analysis. 19 | 20 | It currently includes functions for performing power-scaling sensitivity 21 | analysis on Stan models. This is a way to check how sensitive a 22 | posterior is to perturbations of the prior and likelihood and diagnose 23 | the cause of sensitivity. For efficient computation, power-scaling 24 | sensitivity analysis relies on Pareto smoothed importance sampling 25 | (Vehtari et al., 2024) and importance weighted moment matching (Paananen 26 | et al., 2021). 27 | 28 | Power-scaling sensitivity analysis and priorsense are described in 29 | [Kallioinen et al. (2023)](https://doi.org/10.1007/s11222-023-10366-5). 30 | 31 | ## Installation 32 | 33 | Download the stable version from CRAN with: 34 | 35 | ``` r 36 | install.packages("priorsense") 37 | ``` 38 | 39 | Download the development version from [GitHub](https://github.com/) 40 | with: 41 | 42 | ``` r 43 | # install.packages("remotes") 44 | remotes::install_github("n-kall/priorsense", ref = "development") 45 | ``` 46 | 47 | ## Usage 48 | 49 | priorsense works with models created with rstan, cmdstanr, brms, R2jags, 50 | or with draws objects from the posterior package. 51 | 52 | ### Example 53 | 54 | Consider a simple univariate model with unknown mu and sigma fit to some 55 | data y (available via`example_powerscale_model("univariate_normal")`): 56 | 57 | ``` stan 58 | data { 59 | int N; 60 | array[N] real y; 61 | } 62 | parameters { 63 | real mu; 64 | real sigma; 65 | } 66 | model { 67 | // priors 68 | target += normal_lpdf(mu | 0, 1); 69 | target += normal_lpdf(sigma | 0, 2.5); 70 | // likelihood 71 | target += normal_lpdf(y | mu, sigma); 72 | } 73 | generated quantities { 74 | vector[N] log_lik; 75 | real lprior; 76 | // log likelihood 77 | for (n in 1:N) log_lik[n] = normal_lpdf(y[n] | mu, sigma); 78 | // joint log prior 79 | lprior = normal_lpdf(mu | 0, 1) + 80 | normal_lpdf(sigma | 0, 2.5); 81 | ``` 82 | 83 | We first fit the model using Stan: 84 | 85 | ``` r 86 | library(priorsense) 87 | 88 | normal_model <- example_powerscale_model("univariate_normal") 89 | 90 | fit <- rstan::stan( 91 | model_code = normal_model$model_code, 92 | data = normal_model$data, 93 | refresh = FALSE, 94 | seed = 123 95 | ) 96 | ``` 97 | 98 | Once fit, sensitivity can be checked as follows: 99 | 100 | ``` r 101 | powerscale_sensitivity(fit) 102 | ``` 103 | 104 | Sensitivity based on cjs_dist 105 | Prior selection: all priors 106 | Likelihood selection: all data 107 | 108 | variable prior likelihood diagnosis 109 | mu 0.43 0.64 potential prior-data conflict 110 | sigma 0.36 0.67 potential prior-data conflict 111 | 112 | To visually inspect changes to the posterior, use one of the diagnostic 113 | plot functions. Estimates with high Pareto-k values may be inaccurate 114 | and are indicated. 115 | 116 | ``` r 117 | powerscale_plot_dens(fit) 118 | ``` 119 | 120 | 121 | 122 | ``` r 123 | powerscale_plot_ecdf(fit) 124 | ``` 125 | 126 | 127 | 128 | ``` r 129 | powerscale_plot_quantities(fit) 130 | ``` 131 | 132 | 134 | 135 | In some cases, setting `moment_match = TRUE` will improve the unreliable 136 | estimates at the cost of some further computation. This requires the 137 | [`iwmm` package](https://github.com/topipa/iwmm). 138 | 139 | ## Contributing 140 | 141 | Contributions are welcome! If you find an bug or have an idea for a 142 | feature, open an issue. If you are able to fix an issue, fork the 143 | repository and make a pull request to the `development` branch. 144 | 145 | ## References 146 | 147 | Noa Kallioinen, Topi Paananen, Paul-Christian Bürkner, Aki Vehtari 148 | (2023). Detecting and diagnosing prior and likelihood sensitivity with 149 | power-scaling. Statistics and Computing. 34, 57. 150 | https://doi.org/10.1007/s11222-023-10366-5 151 | 152 | Topi Paananen, Juho Piironen, Paul-Christian Bürkner, Aki Vehtari 153 | (2021). Implicitly adaptive importance sampling. Statistics and 154 | Computing 31, 16. https://doi.org/10.1007/s11222-020-09982-2 155 | 156 | Aki Vehtari, Daniel Simpson, Andrew Gelman, Yuling Yao, Jonah Gabry 157 | (2024). Pareto smoothed importance sampling. Journal of Machine Learning 158 | Research. 25, 72. https://jmlr.org/papers/v25/19-556.html 159 | -------------------------------------------------------------------------------- /README.qmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "priorsense" 3 | format: gfm 4 | default-image-extension: "" 5 | --- 6 | 7 | 8 | 9 | ```{r} 10 | #| include: false 11 | ggplot2::theme_set(bayesplot::theme_default(base_family = "sans")) 12 | ``` 13 | 14 | 15 | [![Lifecycle: stable](https://img.shields.io/badge/lifecycle-stable-green.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) 16 | [![CRAN status](https://www.r-pkg.org/badges/version/priorsense)](https://CRAN.R-project.org/package=priorsense) 17 | [![R-CMD-check](https://github.com/n-kall/priorsense/workflows/R-CMD-check/badge.svg)](https://github.com/n-kall/priorsense/actions) 18 | 19 | 20 | ## Overview 21 | 22 | priorsense provides tools for prior diagnostics and sensitivity 23 | analysis. 24 | 25 | It currently includes functions for performing power-scaling 26 | sensitivity analysis on Stan models. This is a way to check how 27 | sensitive a posterior is to perturbations of the prior and likelihood 28 | and diagnose the cause of sensitivity. For efficient computation, 29 | power-scaling sensitivity analysis relies on Pareto smoothed 30 | importance sampling (Vehtari et al., 2024) and importance weighted 31 | moment matching (Paananen et al., 2021). 32 | 33 | Power-scaling sensitivity analysis and priorsense are described in 34 | [Kallioinen et al. (2023)](https://doi.org/10.1007/s11222-023-10366-5). 35 | 36 | ## Installation 37 | 38 | Download the stable version from CRAN with: 39 | 40 | ```{r} 41 | #| eval: false 42 | install.packages("priorsense") 43 | ``` 44 | 45 | 46 | Download the development version from [GitHub](https://github.com/) with: 47 | 48 | ```{r} 49 | #| eval: false 50 | # install.packages("remotes") 51 | remotes::install_github("n-kall/priorsense", ref = "development") 52 | ``` 53 | 54 | ## Usage 55 | 56 | priorsense works with models created with rstan, cmdstanr, brms, R2jags, or 57 | with draws objects from the posterior package. 58 | 59 | ### Example 60 | 61 | Consider a simple univariate model with unknown mu and sigma fit to 62 | some data y (available 63 | via`example_powerscale_model("univariate_normal")`): 64 | 65 | ```stan 66 | data { 67 | int N; 68 | array[N] real y; 69 | } 70 | parameters { 71 | real mu; 72 | real sigma; 73 | } 74 | model { 75 | // priors 76 | target += normal_lpdf(mu | 0, 1); 77 | target += normal_lpdf(sigma | 0, 2.5); 78 | // likelihood 79 | target += normal_lpdf(y | mu, sigma); 80 | } 81 | generated quantities { 82 | vector[N] log_lik; 83 | real lprior; 84 | // log likelihood 85 | for (n in 1:N) log_lik[n] = normal_lpdf(y[n] | mu, sigma); 86 | // joint log prior 87 | lprior = normal_lpdf(mu | 0, 1) + 88 | normal_lpdf(sigma | 0, 2.5); 89 | ``` 90 | 91 | We first fit the model using Stan: 92 | 93 | ```r 94 | library(priorsense) 95 | 96 | normal_model <- example_powerscale_model("univariate_normal") 97 | 98 | fit <- rstan::stan( 99 | model_code = normal_model$model_code, 100 | data = normal_model$data, 101 | refresh = FALSE, 102 | seed = 123 103 | ) 104 | ``` 105 | 106 | ```{r} 107 | #| include: false 108 | devtools::load_all() 109 | normal_model <- example_powerscale_model("univariate_normal") 110 | fit <- normal_model$draws 111 | ``` 112 | 113 | 114 | Once fit, sensitivity can be checked as follows: 115 | ```{r} 116 | powerscale_sensitivity(fit) 117 | ``` 118 | 119 | To visually inspect changes to the posterior, use one of the 120 | diagnostic plot functions. Estimates with high Pareto-k values may be 121 | inaccurate and are indicated. 122 | 123 | ```{r, powerscale-plot_dens} 124 | #| fig.path: "man/figures/" 125 | #| out.width: "70%" 126 | powerscale_plot_dens(fit) 127 | ``` 128 | 129 | ```{r, powerscale_plot_ecdf} 130 | #| fig.path: "man/figures/" 131 | #| out.width: "70%" 132 | powerscale_plot_ecdf(fit) 133 | ``` 134 | 135 | ```{r, powerscale_plot_quantities} 136 | #| fig.path: "man/figures/" 137 | #| out.width: "70%" 138 | powerscale_plot_quantities(fit) 139 | ``` 140 | 141 | In some cases, setting `moment_match = TRUE` will improve the 142 | unreliable estimates at the cost of some further computation. This 143 | requires the [`iwmm` package](https://github.com/topipa/iwmm). 144 | 145 | 146 | ## Contributing 147 | 148 | Contributions are welcome! If you find an bug or have an idea for a feature, open an issue. If you are able to fix an issue, fork the repository and make a pull request to the `development` branch. 149 | 150 | ## References 151 | 152 | Noa Kallioinen, Topi Paananen, Paul-Christian Bürkner, Aki Vehtari 153 | (2023). Detecting and diagnosing prior and likelihood sensitivity 154 | with power-scaling. Statistics and Computing. 34, 57. 155 | https://doi.org/10.1007/s11222-023-10366-5 156 | 157 | Topi Paananen, Juho Piironen, Paul-Christian Bürkner, Aki Vehtari (2021). 158 | Implicitly adaptive importance sampling. Statistics and Computing 159 | 31, 16. https://doi.org/10.1007/s11222-020-09982-2 160 | 161 | Aki Vehtari, Daniel Simpson, Andrew Gelman, Yuling Yao, Jonah Gabry (2024). 162 | Pareto smoothed importance sampling. Journal of 163 | Machine Learning Research. 25, 72. https://jmlr.org/papers/v25/19-556.html 164 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://n-kall.github.io/priorsense/ 2 | template: 3 | bootstrap: 5 4 | 5 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | 3 | * GitHub Actions (ubuntu-16.04): 3.3, 3.4, 3.5, oldrel, release, devel 4 | * GitHub Actions (windows): release 5 | * Github Actions (macOS): release, devel 6 | * win-builder: devel 7 | 8 | ## R CMD check results 9 | 10 | 0 errors | 0 warnings | 1 note 11 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry( 2 | bibtype = "article", 3 | title = "Detecting and diagnosing prior and likelihood sensitivity with power-scaling", 4 | author = c( 5 | person(given = "Noa", family = "Kallioinen"), 6 | person(given = "Topi", family = "Paananen"), 7 | person(given = "Paul-Christian", family = "Bürkner"), 8 | person(given = "Aki", family = "Vehtari") 9 | ), 10 | year = "2023", 11 | journal = "Statistics and Computing", 12 | volume = 34, 13 | issue = 57, 14 | doi = "10.1007/s11222-023-10366-5", 15 | header = "To cite the priorsense package and power-scaling sensitivity:", 16 | textVersion = paste("Kallioinen, N., Paananen, T., Bürkner, P-C., Vehtari, A. (2023).", 17 | "Detecting and diagnosing prior and likelihood sensitivity with power-scaling.", 18 | "Statistics and Computing. 34(57).", 19 | "doi:10.1007/s11222-023-10366-5"), 20 | encoding = "UTF-8" 21 | ) 22 | 23 | bibentry( 24 | bibtype = "article", 25 | title = "Pareto smoothed importance sampling", 26 | author = c( 27 | person(given = "Aki", family = "Vehtari"), 28 | person(given = "Daniel", family = "Simpson"), 29 | person(given = "Andrew", family = "Gelman"), 30 | person(given = "Yuling", family = "Yao"), 31 | person(given = "Jonah", family = "Gabry") 32 | ), 33 | journal = "Journal of Machine Learning Research", 34 | volume = 25, 35 | issue = 72, 36 | year = "2024", 37 | header = "To cite Pareto-smoothed importance sampling:", 38 | textVersion = paste( 39 | "Aki Vehtari, Daniel Simpson, Andrew Gelman, Yuling Yao, Jonah Gabry (2024).", 40 | "Pareto smoothed importance sampling.", 41 | "Journal of Machine Learning Research 25(72)", 42 | "https://jmlr.org/papers/v25/19-556.html" 43 | ) 44 | ) 45 | 46 | bibentry( 47 | bibtype = "Article", 48 | title = "Implicitly adaptive importance sampling", 49 | author = c( 50 | person(given = "Topi", family = "Paananen"), 51 | person(given = "Juho", family = "Piironen"), 52 | person(given = "Paul-Christian", family = "Bürkner"), 53 | person(given = "Aki", family = "Vehtari") 54 | ), 55 | year = "2021", 56 | journal = "Statistics and Computing", 57 | volume = 31, 58 | issue = 16, 59 | pages = "1--19", 60 | doi = "10.1007/s11222-020-09982-2", 61 | header = "To cite importance weighted moment matching:", 62 | textVersion = paste( 63 | "Topi Paananen, Juho Piironen, Paul-Christian Bürkner, Aki Vehtari (2021).", 64 | "Implicitly adaptive importance sampling.", 65 | "Statistics and Computing, 31(16), 1-19.", 66 | "doi:10.1007/s11222-020-09982-2" 67 | ), 68 | encoding = "UTF-8" 69 | ) 70 | -------------------------------------------------------------------------------- /inst/logo/logo.R: -------------------------------------------------------------------------------- 1 | library(hexSticker) 2 | library(priorsense) 3 | library(bayesplot) 4 | library(ggplot2) 5 | library(cmdstanr) 6 | 7 | theme_set(bayesplot_theme_get()) 8 | 9 | x <- example_powerscale_model() 10 | 11 | m <- cmdstan_model(write_stan_file(x$model_code), force_recompile = TRUE) 12 | 13 | f <- m$sample(data = x$data, iter_sampling = 20000, seed = 123) 14 | 15 | d <- f$draws() 16 | 17 | ps <- powerscale_sequence(f, lower_alpha = 0.77, length = 5, 18 | component = "prior", variable = "mu", 19 | moment_match = FALSE) 20 | 21 | p <- powerscale_plot_dens(ps, help_text = FALSE, intervals = NULL) + 22 | theme(legend.key = element_blank(), legend.text = element_blank(), 23 | legend.title = element_blank(), 24 | axis.title = element_blank(), axis.line = element_blank(), 25 | strip.text = element_blank(), 26 | axis.text = element_blank(), axis.ticks = element_blank()) + 27 | guides(colour = "none", linetype = "none") 28 | 29 | sticker(p, 30 | package = "priorsense", 31 | filename = "man/figures/logo.png", 32 | p_size = 16, p_color = "#221F21", 33 | h_fill = "white", h_color = "black", 34 | s_width = 7.5, s_height = 1.3, 35 | s_x = -1.15, s_y = 1.05, p_x = 0.7, p_y = 1.33 36 | ) 37 | -------------------------------------------------------------------------------- /man-roxygen/alpha_args.R: -------------------------------------------------------------------------------- 1 | ##' @param alpha Value by which to power-scale specified 2 | ##' component. (likelihood/prior). 3 | ##' @param lower_alpha Lower power-scaling alpha value in sequence. 4 | ##' @param upper_alpha Upper power-scaling alpha value in sequence. 5 | ##' @param length Length of alpha sequence. 6 | ##' @param auto_alpha_range Boolean. Restrict range to ensure Pareto-k 7 | ##' values below threshold? 8 | ##' @param symmetric Boolean. Should the alpha range be symmetrical 9 | ##' around alpha = 1, on log-space? 10 | -------------------------------------------------------------------------------- /man-roxygen/div_measure_arg.R: -------------------------------------------------------------------------------- 1 | ##' @srrstats {G2.3b} case sensitive is indicated 2 | ##' @param div_measure Character (case sensitive) specifying the 3 | ##' divergence measure to use. The following methods are 4 | ##' implemented: 5 | ##' 6 | ##' * `"cjs_dist"`: Cumulative Jensen-Shannon distance. Default 7 | ##' method. See function `cjs_dist` for more details. 8 | ##' 9 | ##' * `"js_dist"`: Jensen-Shannon distance. 10 | ##' 11 | ##' * `"js_div"`: Jensen-Shannon divergence. 12 | ##' 13 | ##' * `"hellinger_dist"`: Hellinger distance. 14 | ##' 15 | ##' * `"kl_dist"`: Kullback-Leibler distance. 16 | ##' 17 | ##' * `"kl_div"`: Kullback-Leibler divergence. 18 | ##' 19 | ##' * `"ks_dist"`: Kolmogorov-Smirnov distance. 20 | ##' 21 | ##' * `"hellinger_dist"`: Hellinger distance. 22 | ##' 23 | ##' * `"ws_dist"`: Wassterstein distance (pass `measure_args = list(p = N)`) 24 | ##' for a different order, where N is the order. 25 | ##' @param measure_args Named list of further arguments passed to divergence measure functions. 26 | -------------------------------------------------------------------------------- /man-roxygen/draws_and_weights_arg.R: -------------------------------------------------------------------------------- 1 | ##' @srrstats {2.1a} Type of vector specified 2 | ##' @param x numeric vector of draws from first distribution 3 | ##' @param y numeric vector of draws from second distribution 4 | ##' @param x_weights numeric vector (same length as x) of weights for 5 | ##' the draws of the first distribution 6 | ##' @param y_weights numeric vector (same length as y) of weights for 7 | ##' the draws of the second distribution 8 | -------------------------------------------------------------------------------- /man-roxygen/fit_arg.R: -------------------------------------------------------------------------------- 1 | ##' @param x A fitted model object. 2 | -------------------------------------------------------------------------------- /man-roxygen/ggplot_return.R: -------------------------------------------------------------------------------- 1 | ##' @return A ggplot object (or a `priorsense_plot` object which is a 2 | ##' list of ggplot objects if there is more than one page) that can 3 | ##' be further customized using the **ggplot2** package. 4 | -------------------------------------------------------------------------------- /man-roxygen/log_comp_name.R: -------------------------------------------------------------------------------- 1 | ##' @srrstats {G2.3} case sensitive is indicated 2 | ##' @srrstats {G2.3b} case sensitive is indicated 3 | ##' @param log_prior_name Character (case sensitive) specifying name of the variable storing the log prior evaluations 4 | ##' @param log_lik_name Character (case sensitive) specifying name of the variable storing the log likelihood evaluations 5 | -------------------------------------------------------------------------------- /man-roxygen/log_lik_log_prior.R: -------------------------------------------------------------------------------- 1 | ##' @param log_prior_fn A function that takes as input the model fit 2 | ##' and returns the log prior values. 3 | ##' @param joint_log_lik_fn A function that takes as input the model 4 | ##' fit and returns the joint log likelihood values. 5 | -------------------------------------------------------------------------------- /man-roxygen/plot_args.R: -------------------------------------------------------------------------------- 1 | ##' @param x An object of class `powerscaled_sequence` or an object 2 | ##' for which `powerscale_sequence` will first be run on. 3 | ##' @param variable A character vector of variable names. If `NULL` 4 | ##' (the default) all variables will be plotted. 5 | ##' @param quantity A character vector specifying one or several 6 | ##' quantities to plot. Options are "mean", "median", "sd", "mad", 7 | ##' "quantile". 8 | ##' @param quantity_args Named list of further arguments passed to 9 | ##' quantity functions. Passed as `.args` to 10 | ##' `[posterior::summarise_draws]`. 11 | ##' @param length Numeric specifying how many alpha values should be 12 | ##' used. Ignored of the object is of class `powerscaled_sequence`. 13 | ##' @param mcse Boolean; If TRUE will plot +/- 2 * Monte Carlo 14 | ##' standard error of the base quantity on the quantities plot. 15 | ##' @param help_text Logical indicating whether title and subtitle 16 | ##' with explanatory description should be included in the 17 | ##' plot. Default is TRUE. Can be set via option 18 | ##' "priorsense.show_help_text". 19 | ##' @param colors Character vector of colors to be used for 20 | ##' plots. Either length 3 for `powerscale_plot_ecdf` and 21 | ##' `powerscale_plot_dens` with order lowest, base, highest; or 22 | ##' length 2 for `powerscale_plot_quantities` with order low Pareto 23 | ##' k, high Pareto k. If `NULL` the defaults will be used. 24 | ##' @param facet_rows Character defining the rows of the plot facets, 25 | ##' either "variable" or "component". Default is "variable". 26 | ##' @param variables_per_page Number specifying the maximum number of 27 | ##' variables to show on each page of the plot. Default is 6. If 28 | ##' `NULL` or `Inf`, all variables will be plotted on the same page. 29 | ##' @param ... Arguments passed to `powerscale_sequence` if `x` is not 30 | ##' of class `powerscaled_sequence`. 31 | -------------------------------------------------------------------------------- /man-roxygen/powerscale_args.R: -------------------------------------------------------------------------------- 1 | ##' @param moment_match Logical; Indicate whether or not moment 2 | ##' matching should be performed. Can only be TRUE if `is_method` is 3 | ##' "psis". 4 | ##' @param transform Indicate a transformation of posterior draws to 5 | ##' perform before sensitivity analysis. Either "scale" or "whiten". 6 | ##' @param k_threshold Threshold value for Pareto k values above which 7 | ##' the moment matching algorithm is used. Default is 0.5. 8 | ##' @param resample Logical; Indicate whether or not draws should be 9 | ##' resampled based on calculated importance weights. 10 | -------------------------------------------------------------------------------- /man-roxygen/powerscale_references.R: -------------------------------------------------------------------------------- 1 | ##' @references 2 | ##' 3 | ##' Kallioinen, N., Paananen, T., Bürkner, P-C., Vehtari, A. (2023). 4 | ##' Detecting and diagnosing prior and likelihood sensitivity with 5 | ##' power-scaling perturbations. \emph{Statistics and 6 | ##' Computing}. 34(57). \code{doi:10.1007/s11222-023-10366-5} 7 | ##' 8 | ##' Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, 9 | ##' J. (2024). Pareto smoothed importance sampling. \emph{Journal of 10 | ##' Machine Learning Research}. 25(72). 11 | ##' \code{https://jmlr.org/papers/v25/19-556.html} 12 | ##' 13 | ##' Paananen, T., Piironen, J., Bürkner, P-C., Vehtari, A. (2021). 14 | ##' Implicitly adaptive importance sampling. \emph{Statistics and 15 | ##' Computing}. 31(16). \code{doi:10.1007/s11222-020-09982-2} 16 | -------------------------------------------------------------------------------- /man-roxygen/prediction_arg.R: -------------------------------------------------------------------------------- 1 | ##' @param prediction Function taking the model fit and returning a 2 | ##' draws_df of predictions to be appended to the posterior draws 3 | -------------------------------------------------------------------------------- /man-roxygen/resample_arg.R: -------------------------------------------------------------------------------- 1 | ##' @param resample Logical; Indicate whether or not draws should be 2 | ##' resampled based on calculated importance weights. 3 | -------------------------------------------------------------------------------- /man-roxygen/selection_arg.R: -------------------------------------------------------------------------------- 1 | ##' @param prior_selection Vector specifying partitions of component to be 2 | ##' included in power-scaling. Default is NULL, which takes all 3 | ##' partitions. If this is a character, then it is appended to the 4 | ##' variable name (specified by `log_prior_name`) with an `_` 5 | ##' between them. If numeric, then it is appended inside `[]`. 6 | ##' @param likelihood_selection Vector specifying partitions of component to be 7 | ##' included in power-scaling. Default is NULL, which takes all 8 | ##' partitions. If this is a character, then it is appended to the 9 | ##' variable name (specified by `log_lik_name`) with an `_` 10 | ##' between them. If numeric, then it is appended inside `[]`. 11 | -------------------------------------------------------------------------------- /man/cjs_dist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cjs.R 3 | \name{cjs_dist} 4 | \alias{cjs_dist} 5 | \title{Cumulative Jensen-Shannon divergence} 6 | \usage{ 7 | cjs_dist( 8 | x, 9 | y, 10 | x_weights = NULL, 11 | y_weights = NULL, 12 | metric = TRUE, 13 | unsigned = TRUE, 14 | ... 15 | ) 16 | } 17 | \arguments{ 18 | \item{x}{numeric vector of draws from first distribution} 19 | 20 | \item{y}{numeric vector of draws from second distribution} 21 | 22 | \item{x_weights}{numeric vector (same length as x) of weights for 23 | the draws of the first distribution} 24 | 25 | \item{y_weights}{numeric vector (same length as y) of weights for 26 | the draws of the second distribution} 27 | 28 | \item{metric}{Logical; if TRUE, return square-root of CJS. Default 29 | is TRUE} 30 | 31 | \item{unsigned}{Logical; if TRUE then return max of CJS(P(x) || 32 | Q(x)) and CJS(P(-x) || Q(-x)). This ensures invariance to 33 | transformations such as PCA. Default is TRUE} 34 | 35 | \item{...}{unused} 36 | } 37 | \value{ 38 | distance value based on CJS computation. 39 | } 40 | \description{ 41 | Computes the cumulative Jensen-Shannon distance between two 42 | samples. 43 | } 44 | \details{ 45 | The Cumulative Jensen-Shannon distance is a symmetric metric based 46 | on the cumulative Jensen-Shannon divergence. The divergence CJS(P || Q) 47 | between two cumulative distribution functions P and Q is defined as: 48 | 49 | \deqn{CJS(P || Q) = \sum P(x) \log \frac{P(x)}{0.5 (P(x) + Q(x))} + 50 | \frac{1}{2 \ln 2} \sum (Q(x) - P(x))} 51 | 52 | The symmetric metric is defined as: 53 | 54 | \deqn{CJS_{dist}(P || Q) = \sqrt{CJS(P || Q) + CJS(Q || P)}} 55 | 56 | This has an upper bound of \eqn{\sqrt{ \sum (P(x) + Q(x))}} 57 | } 58 | \examples{ 59 | x <- rnorm(100) 60 | y <- rnorm(100, 2, 2) 61 | cjs_dist(x, y, x_weights = NULL, y_weights = NULL) 62 | } 63 | \references{ 64 | Nguyen H-V., Vreeken J. (2015). Non-parametric 65 | Jensen-Shannon Divergence. In: Appice A., Rodrigues P., Santos 66 | Costa V., Gama J., Jorge A., Soares C. (eds) Machine Learning 67 | and Knowledge Discovery in Databases. ECML PKDD 2015. Lecture 68 | Notes in Computer Science, vol 9285. Springer, Cham. 69 | \code{doi:10.1007/978-3-319-23525-7_11} 70 | } 71 | -------------------------------------------------------------------------------- /man/create-priorsense-data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/create_priorsense_data.R 3 | \name{create-priorsense-data} 4 | \alias{create-priorsense-data} 5 | \alias{create_priorsense_data} 6 | \alias{create_priorsense_data.default} 7 | \alias{create_priorsense_data.stanfit} 8 | \alias{create_priorsense_data.CmdStanFit} 9 | \alias{create_priorsense_data.draws} 10 | \alias{create_priorsense_data.rjags} 11 | \title{Create data structure for priorsense} 12 | \usage{ 13 | create_priorsense_data(x, ...) 14 | 15 | \method{create_priorsense_data}{default}( 16 | x, 17 | fit = NULL, 18 | log_prior_fn = log_prior_draws, 19 | log_lik_fn = log_lik_draws, 20 | log_prior = NULL, 21 | log_lik = NULL, 22 | log_ratio_fn = NULL, 23 | log_prior_name = "lprior", 24 | log_lik_name = "log_lik", 25 | ... 26 | ) 27 | 28 | \method{create_priorsense_data}{stanfit}(x, ...) 29 | 30 | \method{create_priorsense_data}{CmdStanFit}(x, ...) 31 | 32 | \method{create_priorsense_data}{draws}(x, ...) 33 | 34 | \method{create_priorsense_data}{rjags}(x, ...) 35 | } 36 | \arguments{ 37 | \item{x}{an object for which the method is defined or an object 38 | coercible to a \code{posterior::draws} object} 39 | 40 | \item{...}{arguments passed to methods} 41 | 42 | \item{fit}{a model fit object (only used if x is not a fit object)} 43 | 44 | \item{log_prior_fn}{function to derive log prior from x or fit (if 45 | not NULL)} 46 | 47 | \item{log_lik_fn}{function to derive log likelihood from x or fit 48 | (if not NULL)} 49 | 50 | \item{log_prior}{draws object from log prior, must be numeric and 51 | not include NA, NaN, Inf, -Inf or be constant} 52 | 53 | \item{log_lik}{draws from log likelihood, must be numeric and not 54 | include NA, NaN, Inf, -Inf or be constant} 55 | 56 | \item{log_ratio_fn}{function for moment matching} 57 | 58 | \item{log_prior_name}{Character (case sensitive) specifying name of the variable storing the log prior evaluations} 59 | 60 | \item{log_lik_name}{Character (case sensitive) specifying name of the variable storing the log likelihood evaluations} 61 | } 62 | \value{ 63 | A \code{priorsense_data} object, which contains the data and 64 | functions to run sensitivity analyses. 65 | } 66 | \description{ 67 | Create a data structure that contains all required data and 68 | functions for priorsense 69 | } 70 | \examples{ 71 | x <- example_powerscale_model() 72 | drw <- x$draws 73 | 74 | psd <- create_priorsense_data(drw) 75 | } 76 | -------------------------------------------------------------------------------- /man/example_powerscale_model.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/example_powerscale_model.R 3 | \name{example_powerscale_model} 4 | \alias{example_powerscale_model} 5 | \title{Example Stan model for power-scaling} 6 | \usage{ 7 | example_powerscale_model(model = "univariate_normal") 8 | } 9 | \arguments{ 10 | \item{model}{Character specifying which model code to 11 | return. Currently "univariate_normal" and "eight_schools" are 12 | implemented.} 13 | } 14 | \value{ 15 | List containing model code and corresponding data. 16 | } 17 | \description{ 18 | Provides example models (with data) that are ready for use with 19 | power-scaling. 20 | } 21 | \examples{ 22 | ex_normal <- example_powerscale_model(model = "univariate_normal") 23 | 24 | ex_eightschools <- example_powerscale_model(model = "eight_schools") 25 | } 26 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/n-kall/priorsense/c482f522d399dcc23cdee541c2e96098f044aef9/man/figures/logo.png -------------------------------------------------------------------------------- /man/figures/powerscale-plot_dens-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/n-kall/priorsense/c482f522d399dcc23cdee541c2e96098f044aef9/man/figures/powerscale-plot_dens-1.png -------------------------------------------------------------------------------- /man/figures/powerscale_plot_ecdf-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/n-kall/priorsense/c482f522d399dcc23cdee541c2e96098f044aef9/man/figures/powerscale_plot_ecdf-1.png -------------------------------------------------------------------------------- /man/figures/powerscale_plot_quantities-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/n-kall/priorsense/c482f522d399dcc23cdee541c2e96098f044aef9/man/figures/powerscale_plot_quantities-1.png -------------------------------------------------------------------------------- /man/log_lik_draws.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/log_lik_draws.R 3 | \name{log_lik_draws} 4 | \alias{log_lik_draws} 5 | \alias{log_lik_draws.stanfit} 6 | \alias{log_lik_draws.CmdStanFit} 7 | \alias{log_lik_draws.draws} 8 | \title{Extract log likelihood draws} 9 | \usage{ 10 | log_lik_draws(x, ...) 11 | 12 | \method{log_lik_draws}{stanfit}(x, joint = FALSE, log_lik_name = "log_lik", ...) 13 | 14 | \method{log_lik_draws}{CmdStanFit}(x, joint = FALSE, log_lik_name = "log_lik", ...) 15 | 16 | \method{log_lik_draws}{draws}(x, joint = FALSE, log_lik_name = "log_lik", ...) 17 | } 18 | \arguments{ 19 | \item{x}{Model fit or draws object.} 20 | 21 | \item{...}{Arguments passed to individual methods.} 22 | 23 | \item{joint}{Logical indicating whether to return the joint log 24 | likelihood or array. Default is FALSE.} 25 | 26 | \item{log_lik_name}{Name of parameter in Stan model corresponding 27 | to log likelihood, default is "log_lik".} 28 | } 29 | \value{ 30 | A draws_array object containing log_lik values. 31 | } 32 | \description{ 33 | Extract log likelihood from fitted model and return as a draws 34 | object. 35 | } 36 | \examples{ 37 | ex <- example_powerscale_model() 38 | drw <- ex$draws 39 | 40 | log_lik_draws(drw) 41 | 42 | } 43 | -------------------------------------------------------------------------------- /man/log_prior_draws.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/log_prior_draws.R 3 | \name{log_prior_draws} 4 | \alias{log_prior_draws} 5 | \alias{log_prior_draws.stanfit} 6 | \alias{log_prior_draws.CmdStanFit} 7 | \alias{log_prior_draws.draws} 8 | \title{Extract log prior draws} 9 | \usage{ 10 | log_prior_draws(x, ...) 11 | 12 | \method{log_prior_draws}{stanfit}(x, joint = FALSE, log_prior_name = "lprior", ...) 13 | 14 | \method{log_prior_draws}{CmdStanFit}(x, joint = FALSE, log_prior_name = "lprior", ...) 15 | 16 | \method{log_prior_draws}{draws}(x, joint = FALSE, log_prior_name = "lprior", ...) 17 | } 18 | \arguments{ 19 | \item{x}{Model fit or draws object.} 20 | 21 | \item{...}{Arguments passed to individual methods.} 22 | 23 | \item{joint}{Logical indicating whether to return the joint log 24 | prior or array. Default is FALSE.} 25 | 26 | \item{log_prior_name}{Name of parameter in Stan model 27 | corresponding to log prior, default is "lprior".} 28 | } 29 | \value{ 30 | A draws_array object containing log_prior values. 31 | } 32 | \description{ 33 | Extract log likelihood from fitted model and return as a draws 34 | object. 35 | } 36 | \examples{ 37 | ex <- example_powerscale_model() 38 | drw <- ex$draws 39 | 40 | log_prior_draws(drw) 41 | 42 | } 43 | -------------------------------------------------------------------------------- /man/powerscale-gradients.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/powerscale_gradients.R 3 | \name{powerscale-gradients} 4 | \alias{powerscale-gradients} 5 | \alias{powerscale_gradients} 6 | \alias{powerscale_gradients.default} 7 | \alias{powerscale_gradients.priorsense_data} 8 | \title{Power-scale gradients} 9 | \usage{ 10 | powerscale_gradients(x, ...) 11 | 12 | \method{powerscale_gradients}{default}( 13 | x, 14 | log_prior_name = "lprior", 15 | log_lik_name = "log_lik", 16 | ... 17 | ) 18 | 19 | \method{powerscale_gradients}{priorsense_data}( 20 | x, 21 | variable = NULL, 22 | component = c("prior", "likelihood"), 23 | type = c("quantities", "divergence"), 24 | lower_alpha = 0.99, 25 | upper_alpha = 1.01, 26 | div_measure = "cjs_dist", 27 | measure_args = list(), 28 | moment_match = FALSE, 29 | k_threshold = 0.5, 30 | resample = FALSE, 31 | transform = NULL, 32 | prediction = NULL, 33 | scale = FALSE, 34 | prior_selection = NULL, 35 | likelihood_selection = NULL, 36 | ... 37 | ) 38 | } 39 | \arguments{ 40 | \item{x}{Model fit or draws object.} 41 | 42 | \item{...}{Further arguments passed to functions.} 43 | 44 | \item{log_prior_name}{Character (case sensitive) specifying name of the variable storing the log prior evaluations} 45 | 46 | \item{log_lik_name}{Character (case sensitive) specifying name of the variable storing the log likelihood evaluations} 47 | 48 | \item{variable}{Variables to compute sensitivity of. If NULL 49 | (default) sensitivity is computed for all variables.} 50 | 51 | \item{component}{Component to power-scale (prior or likelihood).} 52 | 53 | \item{type}{type of sensitivity to measure ("distance", 54 | "quantity"). Multiple options can be specified at the same 55 | time.} 56 | 57 | \item{lower_alpha}{lower power to scale component by, should be < 58 | 1 (default is 0.9).} 59 | 60 | \item{upper_alpha}{upper power to scale component by, should be > 61 | 1 (default is 1.1).} 62 | 63 | \item{div_measure}{Character (case sensitive) specifying the 64 | divergence measure to use. The following methods are 65 | implemented: 66 | \itemize{ 67 | \item \code{"cjs_dist"}: Cumulative Jensen-Shannon distance. Default 68 | method. See function \code{cjs_dist} for more details. 69 | \item \code{"js_dist"}: Jensen-Shannon distance. 70 | \item \code{"js_div"}: Jensen-Shannon divergence. 71 | \item \code{"hellinger_dist"}: Hellinger distance. 72 | \item \code{"kl_dist"}: Kullback-Leibler distance. 73 | \item \code{"kl_div"}: Kullback-Leibler divergence. 74 | \item \code{"ks_dist"}: Kolmogorov-Smirnov distance. 75 | \item \code{"hellinger_dist"}: Hellinger distance. 76 | \item \code{"ws_dist"}: Wassterstein distance (pass \code{measure_args = list(p = N)}) 77 | for a different order, where N is the order. 78 | }} 79 | 80 | \item{measure_args}{Named list of further arguments passed to divergence measure functions.} 81 | 82 | \item{moment_match}{Logical; Indicate whether or not moment 83 | matching should be performed. Can only be TRUE if \code{is_method} is 84 | "psis".} 85 | 86 | \item{k_threshold}{Threshold value for Pareto k values above which 87 | the moment matching algorithm is used. Default is 0.5.} 88 | 89 | \item{resample}{Logical; Indicate whether or not draws should be 90 | resampled based on calculated importance weights.} 91 | 92 | \item{transform}{Indicate a transformation of posterior draws to 93 | perform before sensitivity analysis. Either "scale" or "whiten".} 94 | 95 | \item{prediction}{Function taking the model fit and returning a 96 | draws_df of predictions to be appended to the posterior draws} 97 | 98 | \item{scale}{logical scale quantity gradients by base posterior 99 | standard deviation.} 100 | 101 | \item{prior_selection}{Numeric vector specifying which priors to 102 | consider.} 103 | 104 | \item{likelihood_selection}{Numeric vector specifying which likelihoods to 105 | consider.} 106 | } 107 | \value{ 108 | Maximum of the absolute derivatives above and below alpha 109 | = 1. 110 | } 111 | \description{ 112 | Calculate the numerical derivative of posterior 113 | quantities/divergence with respect to power-scaling the specified 114 | component (prior or likelihood). This is done using importance 115 | sampling (and optionally moment matching). 116 | } 117 | \examples{ 118 | ex <- example_powerscale_model() 119 | drw <- ex$draws 120 | 121 | powerscale_gradients(drw) 122 | } 123 | -------------------------------------------------------------------------------- /man/powerscale-overview.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/powerscale.R, R/powerscale_sequence.R 3 | \name{powerscale-overview} 4 | \alias{powerscale-overview} 5 | \alias{powerscale} 6 | \alias{powerscale.default} 7 | \alias{powerscale.priorsense_data} 8 | \alias{powerscale_sequence} 9 | \alias{powerscale_sequence.default} 10 | \alias{powerscale_sequence.priorsense_data} 11 | \title{Prior/likelihood power-scaling perturbation} 12 | \usage{ 13 | powerscale(x, ...) 14 | 15 | \method{powerscale}{default}( 16 | x, 17 | component, 18 | alpha, 19 | moment_match = FALSE, 20 | k_threshold = NULL, 21 | resample = FALSE, 22 | transform = NULL, 23 | prediction = NULL, 24 | variable = NULL, 25 | selection = NULL, 26 | log_prior_name = "lprior", 27 | log_lik_name = "log_lik", 28 | ... 29 | ) 30 | 31 | \method{powerscale}{priorsense_data}( 32 | x, 33 | component, 34 | alpha, 35 | moment_match = FALSE, 36 | k_threshold = NULL, 37 | resample = FALSE, 38 | transform = NULL, 39 | prediction = NULL, 40 | variable = NULL, 41 | selection = NULL, 42 | log_prior_name = "lprior", 43 | log_lik_name = "log_lik", 44 | ... 45 | ) 46 | 47 | powerscale_sequence(x, ...) 48 | 49 | \method{powerscale_sequence}{default}( 50 | x, 51 | lower_alpha = 0.8, 52 | upper_alpha = 1/lower_alpha, 53 | length = 3, 54 | variable = NULL, 55 | component = c("prior", "likelihood"), 56 | moment_match = FALSE, 57 | k_threshold = 0.5, 58 | resample = FALSE, 59 | transform = NULL, 60 | prediction = NULL, 61 | auto_alpha_range = FALSE, 62 | symmetric = TRUE, 63 | prior_selection = NULL, 64 | likelihood_selection = NULL, 65 | ... 66 | ) 67 | 68 | \method{powerscale_sequence}{priorsense_data}( 69 | x, 70 | lower_alpha = 0.8, 71 | upper_alpha = 1/lower_alpha, 72 | length = 3, 73 | variable = NULL, 74 | component = c("prior", "likelihood"), 75 | moment_match = FALSE, 76 | k_threshold = NULL, 77 | resample = FALSE, 78 | transform = NULL, 79 | prediction = NULL, 80 | auto_alpha_range = FALSE, 81 | symmetric = TRUE, 82 | prior_selection = NULL, 83 | likelihood_selection = NULL, 84 | ... 85 | ) 86 | } 87 | \arguments{ 88 | \item{x}{A fitted model object.} 89 | 90 | \item{...}{Further arguments passed to internal functions.} 91 | 92 | \item{component}{Component to be power-scaled (either "prior" or 93 | "likelihood"). For powerscale_sequence, this can be both "prior" 94 | and "likelihood".} 95 | 96 | \item{alpha}{Value by which to power-scale specified 97 | component. (likelihood/prior).} 98 | 99 | \item{moment_match}{Logical; Indicate whether or not moment 100 | matching should be performed. Can only be TRUE if \code{is_method} is 101 | "psis".} 102 | 103 | \item{k_threshold}{Threshold value for Pareto k values above which 104 | the moment matching algorithm is used. Default is 0.5.} 105 | 106 | \item{resample}{Logical; Indicate whether or not draws should be 107 | resampled based on calculated importance weights.} 108 | 109 | \item{transform}{Indicate a transformation of posterior draws to 110 | perform before sensitivity analysis. Either "scale" or "whiten".} 111 | 112 | \item{prediction}{Function taking the model fit and returning a 113 | draws_df of predictions to be appended to the posterior draws} 114 | 115 | \item{variable}{Vector of variable names to return estimated 116 | posterior draws for. If \code{NULL} all variables will be included.} 117 | 118 | \item{selection}{Vector specifying partitions of component to be 119 | included in power-scaling. Default is NULL, which takes all 120 | partitions. If this is a character, then it is appended to the 121 | variable name (\code{log_prior_name} or \code{log_lik_name}) with an \verb{_} 122 | between them.} 123 | 124 | \item{log_prior_name}{Character (case sensitive) specifying name of the variable storing the log prior evaluations} 125 | 126 | \item{log_lik_name}{Character (case sensitive) specifying name of the variable storing the log likelihood evaluations} 127 | 128 | \item{lower_alpha}{Lower power-scaling alpha value in sequence.} 129 | 130 | \item{upper_alpha}{Upper power-scaling alpha value in sequence.} 131 | 132 | \item{length}{Length of alpha sequence.} 133 | 134 | \item{auto_alpha_range}{Boolean. Restrict range to ensure Pareto-k 135 | values below threshold?} 136 | 137 | \item{symmetric}{Boolean. Should the alpha range be symmetrical 138 | around alpha = 1, on log-space?} 139 | 140 | \item{prior_selection}{Vector specifying partitions of component to be 141 | included in power-scaling. Default is NULL, which takes all 142 | partitions. If this is a character, then it is appended to the 143 | variable name (specified by \code{log_prior_name}) with an \verb{_} 144 | between them. If numeric, then it is appended inside \verb{[]}.} 145 | 146 | \item{likelihood_selection}{Vector specifying partitions of component to be 147 | included in power-scaling. Default is NULL, which takes all 148 | partitions. If this is a character, then it is appended to the 149 | variable name (specified by \code{log_lik_name}) with an \verb{_} 150 | between them. If numeric, then it is appended inside \verb{[]}.} 151 | } 152 | \value{ 153 | A \code{powerscaled_draws} or \code{powerscaled_sequence} object, 154 | which contains the estimated posterior draws resulting from the 155 | power-scaling perturbations and details of the perturbation and 156 | estimation methods. 157 | } 158 | \description{ 159 | Estimate posterior draws based on power-scaling perturbations of 160 | prior or likelihood using importance sampling (and optionally 161 | moment matching). 162 | } 163 | \examples{ 164 | ex <- example_powerscale_model() 165 | 166 | powerscale(ex$draws, component = "prior", alpha = 0.5) 167 | 168 | powerscale_sequence(ex$draws) 169 | } 170 | \references{ 171 | Kallioinen, N., Paananen, T., Bürkner, P-C., Vehtari, A. (2023). 172 | Detecting and diagnosing prior and likelihood sensitivity with 173 | power-scaling perturbations. \emph{Statistics and 174 | Computing}. 34(57). \code{doi:10.1007/s11222-023-10366-5} 175 | 176 | Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, 177 | J. (2024). Pareto smoothed importance sampling. \emph{Journal of 178 | Machine Learning Research}. 25(72). 179 | \code{https://jmlr.org/papers/v25/19-556.html} 180 | 181 | Paananen, T., Piironen, J., Bürkner, P-C., Vehtari, A. (2021). 182 | Implicitly adaptive importance sampling. \emph{Statistics and 183 | Computing}. 31(16). \code{doi:10.1007/s11222-020-09982-2} 184 | } 185 | -------------------------------------------------------------------------------- /man/powerscale-sensitivity.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/powerscale_sensitivity.R 3 | \name{powerscale-sensitivity} 4 | \alias{powerscale-sensitivity} 5 | \alias{powerscale_sensitivity} 6 | \alias{powerscale_sensitivity.default} 7 | \alias{powerscale_sensitivity.priorsense_data} 8 | \alias{powerscale_sensitivity.CmdStanFit} 9 | \alias{powerscale_sensitivity.stanfit} 10 | \title{Power-scaling sensitivity analysis} 11 | \usage{ 12 | powerscale_sensitivity(x, ...) 13 | 14 | \method{powerscale_sensitivity}{default}( 15 | x, 16 | variable = NULL, 17 | lower_alpha = 0.99, 18 | upper_alpha = 1.01, 19 | div_measure = "cjs_dist", 20 | measure_args = list(), 21 | component = c("prior", "likelihood"), 22 | sensitivity_threshold = 0.05, 23 | moment_match = FALSE, 24 | k_threshold = 0.5, 25 | resample = FALSE, 26 | transform = NULL, 27 | prediction = NULL, 28 | prior_selection = NULL, 29 | likelihood_selection = NULL, 30 | log_prior_name = "lprior", 31 | log_lik_name = "log_lik", 32 | num_args = NULL, 33 | ... 34 | ) 35 | 36 | \method{powerscale_sensitivity}{priorsense_data}( 37 | x, 38 | variable = NULL, 39 | lower_alpha = 0.99, 40 | upper_alpha = 1.01, 41 | div_measure = "cjs_dist", 42 | measure_args = list(), 43 | component = c("prior", "likelihood"), 44 | sensitivity_threshold = 0.05, 45 | moment_match = FALSE, 46 | k_threshold = 0.5, 47 | resample = FALSE, 48 | transform = NULL, 49 | prediction = NULL, 50 | prior_selection = NULL, 51 | likelihood_selection = NULL, 52 | num_args = NULL, 53 | ... 54 | ) 55 | 56 | \method{powerscale_sensitivity}{CmdStanFit}(x, ...) 57 | 58 | \method{powerscale_sensitivity}{stanfit}(x, ...) 59 | } 60 | \arguments{ 61 | \item{x}{Model fit object or priorsense_data object.} 62 | 63 | \item{...}{Further arguments passed to functions.} 64 | 65 | \item{variable}{Character vector of variables to check.} 66 | 67 | \item{lower_alpha}{Lower alpha value for gradient calculation.} 68 | 69 | \item{upper_alpha}{Upper alpha value for gradient calculation.} 70 | 71 | \item{div_measure}{Character (case sensitive) specifying the 72 | divergence measure to use. The following methods are 73 | implemented: 74 | \itemize{ 75 | \item \code{"cjs_dist"}: Cumulative Jensen-Shannon distance. Default 76 | method. See function \code{cjs_dist} for more details. 77 | \item \code{"js_dist"}: Jensen-Shannon distance. 78 | \item \code{"js_div"}: Jensen-Shannon divergence. 79 | \item \code{"hellinger_dist"}: Hellinger distance. 80 | \item \code{"kl_dist"}: Kullback-Leibler distance. 81 | \item \code{"kl_div"}: Kullback-Leibler divergence. 82 | \item \code{"ks_dist"}: Kolmogorov-Smirnov distance. 83 | \item \code{"hellinger_dist"}: Hellinger distance. 84 | \item \code{"ws_dist"}: Wassterstein distance (pass \code{measure_args = list(p = N)}) 85 | for a different order, where N is the order. 86 | }} 87 | 88 | \item{measure_args}{Named list of further arguments passed to divergence measure functions.} 89 | 90 | \item{component}{Character vector specifying component(s) to scale 91 | (default is both "prior" and "likelihood").} 92 | 93 | \item{sensitivity_threshold}{Threshold for flagging variable as 94 | sensitive to power-scaling.} 95 | 96 | \item{moment_match}{Logical; Indicate whether or not moment 97 | matching should be performed. Can only be TRUE if \code{is_method} is 98 | "psis".} 99 | 100 | \item{k_threshold}{Threshold value for Pareto k values above which 101 | the moment matching algorithm is used. Default is 0.5.} 102 | 103 | \item{resample}{Logical; Indicate whether or not draws should be 104 | resampled based on calculated importance weights.} 105 | 106 | \item{transform}{Indicate a transformation of posterior draws to 107 | perform before sensitivity analysis. Either "scale" or "whiten".} 108 | 109 | \item{prediction}{Function taking the model fit and returning a 110 | draws_df of predictions to be appended to the posterior draws} 111 | 112 | \item{prior_selection}{Vector specifying partitions of component to be 113 | included in power-scaling. Default is NULL, which takes all 114 | partitions. If this is a character, then it is appended to the 115 | variable name (specified by \code{log_prior_name}) with an \verb{_} 116 | between them. If numeric, then it is appended inside \verb{[]}.} 117 | 118 | \item{likelihood_selection}{Vector specifying partitions of component to be 119 | included in power-scaling. Default is NULL, which takes all 120 | partitions. If this is a character, then it is appended to the 121 | variable name (specified by \code{log_lik_name}) with an \verb{_} 122 | between them. If numeric, then it is appended inside \verb{[]}.} 123 | 124 | \item{log_prior_name}{Character (case sensitive) specifying name of the variable storing the log prior evaluations} 125 | 126 | \item{log_lik_name}{Character (case sensitive) specifying name of the variable storing the log likelihood evaluations} 127 | 128 | \item{num_args}{(named list) Optional arguments passed to 129 | \link[tibble:num]{num()} for pretty printing of summaries. Can be 130 | controlled globally via the \code{posterior.num_args} 131 | \link[base:options]{option}.} 132 | } 133 | \value{ 134 | Table of sensitivity values for each specified variable. 135 | } 136 | \description{ 137 | Calculates the prior/likelihood sensitivity based on power-scaling 138 | perturbations. This is done using importance sampling (and 139 | optionally moment matching). 140 | } 141 | \examples{ 142 | ex <- example_powerscale_model() 143 | powerscale_sensitivity(ex$draws) 144 | } 145 | \references{ 146 | Kallioinen, N., Paananen, T., Bürkner, P-C., Vehtari, A. (2023). 147 | Detecting and diagnosing prior and likelihood sensitivity with 148 | power-scaling perturbations. \emph{Statistics and 149 | Computing}. 34(57). \code{doi:10.1007/s11222-023-10366-5} 150 | 151 | Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, 152 | J. (2024). Pareto smoothed importance sampling. \emph{Journal of 153 | Machine Learning Research}. 25(72). 154 | \code{https://jmlr.org/papers/v25/19-556.html} 155 | 156 | Paananen, T., Piironen, J., Bürkner, P-C., Vehtari, A. (2021). 157 | Implicitly adaptive importance sampling. \emph{Statistics and 158 | Computing}. 31(16). \code{doi:10.1007/s11222-020-09982-2} 159 | } 160 | -------------------------------------------------------------------------------- /man/powerscale_derivative.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/powerscale_derivative.R 3 | \name{powerscale_derivative} 4 | \alias{powerscale_derivative} 5 | \title{Derivative with respect to power-scaling} 6 | \usage{ 7 | powerscale_derivative(x, log_component, quantity = "mean", ...) 8 | } 9 | \arguments{ 10 | \item{x}{draws object of posterior draws} 11 | 12 | \item{log_component}{numeric vector of log likelihood or log prior values} 13 | 14 | \item{quantity}{Character specifying quantity of interest (default 15 | is "mean"). Options are "mean", "sd", "var".} 16 | 17 | \item{...}{unused} 18 | } 19 | \value{ 20 | Derivative of the quantity with respect to log2 of the 21 | power-scaling factor (alpha). 22 | } 23 | \description{ 24 | Calculate the analytical derivative of a quantity with respect to 25 | power-scaling prior or likelihood. 26 | } 27 | \examples{ 28 | example_model <- example_powerscale_model() 29 | draws <- example_model$draws 30 | log_prior <- log_prior_draws(draws, joint = TRUE) 31 | posterior::summarise_draws( 32 | posterior::subset_draws(draws, variable = c("mu", "sigma")), 33 | mean, 34 | mean_sens = ~powerscale_derivative(.x, log_prior, quantity = "mean") 35 | ) 36 | } 37 | -------------------------------------------------------------------------------- /man/powerscale_plots.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plots.R 3 | \name{powerscale_plots} 4 | \alias{powerscale_plots} 5 | \alias{powerscale_plot_dens} 6 | \alias{powerscale_plot_ecdf} 7 | \alias{powerscale_plot_ecdf.powerscaled_sequence} 8 | \alias{powerscale_plot_quantities} 9 | \alias{powerscale_plot_quantities.powerscaled_sequence} 10 | \title{Diagnostic plots for power-scaling sensitivity} 11 | \usage{ 12 | powerscale_plot_dens(x, ...) 13 | 14 | powerscale_plot_ecdf(x, ...) 15 | 16 | \method{powerscale_plot_ecdf}{powerscaled_sequence}( 17 | x, 18 | variable = NULL, 19 | resample = FALSE, 20 | length = 3, 21 | facet_rows = "component", 22 | help_text = getOption("priorsense.plot_help_text", TRUE), 23 | colors = NULL, 24 | variables_per_page = getOption("priorsense.plot_variables_per_page", 6), 25 | ... 26 | ) 27 | 28 | powerscale_plot_quantities(x, ...) 29 | 30 | \method{powerscale_plot_quantities}{powerscaled_sequence}( 31 | x, 32 | variable = NULL, 33 | quantity = c("mean", "sd"), 34 | div_measure = "cjs_dist", 35 | resample = FALSE, 36 | measure_args = NULL, 37 | mcse = TRUE, 38 | quantity_args = NULL, 39 | help_text = getOption("priorsense.plot_help_text", TRUE), 40 | colors = NULL, 41 | variables_per_page = getOption("priorsense.plot_variables_per_page", 6), 42 | ... 43 | ) 44 | } 45 | \arguments{ 46 | \item{x}{An object of class \code{powerscaled_sequence} or an object 47 | for which \code{powerscale_sequence} will first be run on.} 48 | 49 | \item{...}{Arguments passed to \code{powerscale_sequence} if \code{x} is not 50 | of class \code{powerscaled_sequence}.} 51 | 52 | \item{variable}{A character vector of variable names. If \code{NULL} 53 | (the default) all variables will be plotted.} 54 | 55 | \item{resample}{Logical; Indicate whether or not draws should be 56 | resampled based on calculated importance weights.} 57 | 58 | \item{length}{Numeric specifying how many alpha values should be 59 | used. Ignored of the object is of class \code{powerscaled_sequence}.} 60 | 61 | \item{facet_rows}{Character defining the rows of the plot facets, 62 | either "variable" or "component". Default is "variable".} 63 | 64 | \item{help_text}{Logical indicating whether title and subtitle 65 | with explanatory description should be included in the 66 | plot. Default is TRUE. Can be set via option 67 | "priorsense.show_help_text".} 68 | 69 | \item{colors}{Character vector of colors to be used for 70 | plots. Either length 3 for \code{powerscale_plot_ecdf} and 71 | \code{powerscale_plot_dens} with order lowest, base, highest; or 72 | length 2 for \code{powerscale_plot_quantities} with order low Pareto 73 | k, high Pareto k. If \code{NULL} the defaults will be used.} 74 | 75 | \item{variables_per_page}{Number specifying the maximum number of 76 | variables to show on each page of the plot. Default is 6. If 77 | \code{NULL} or \code{Inf}, all variables will be plotted on the same page.} 78 | 79 | \item{quantity}{A character vector specifying one or several 80 | quantities to plot. Options are "mean", "median", "sd", "mad", 81 | "quantile".} 82 | 83 | \item{div_measure}{Character (case sensitive) specifying the 84 | divergence measure to use. The following methods are 85 | implemented: 86 | \itemize{ 87 | \item \code{"cjs_dist"}: Cumulative Jensen-Shannon distance. Default 88 | method. See function \code{cjs_dist} for more details. 89 | \item \code{"js_dist"}: Jensen-Shannon distance. 90 | \item \code{"js_div"}: Jensen-Shannon divergence. 91 | \item \code{"hellinger_dist"}: Hellinger distance. 92 | \item \code{"kl_dist"}: Kullback-Leibler distance. 93 | \item \code{"kl_div"}: Kullback-Leibler divergence. 94 | \item \code{"ks_dist"}: Kolmogorov-Smirnov distance. 95 | \item \code{"hellinger_dist"}: Hellinger distance. 96 | \item \code{"ws_dist"}: Wassterstein distance (pass \code{measure_args = list(p = N)}) 97 | for a different order, where N is the order. 98 | }} 99 | 100 | \item{measure_args}{Named list of further arguments passed to divergence measure functions.} 101 | 102 | \item{mcse}{Boolean; If TRUE will plot +/- 2 * Monte Carlo 103 | standard error of the base quantity on the quantities plot.} 104 | 105 | \item{quantity_args}{Named list of further arguments passed to 106 | quantity functions. Passed as \code{.args} to 107 | \verb{[posterior::summarise_draws]}.} 108 | } 109 | \value{ 110 | A ggplot object (or a \code{priorsense_plot} object which is a 111 | list of ggplot objects if there is more than one page) that can 112 | be further customized using the \strong{ggplot2} package. 113 | } 114 | \description{ 115 | Various diagnostic plots for power-scaling sensitivity. See \strong{Plot 116 | Descriptions} below for details. 117 | } 118 | \section{Plot Descriptions}{ 119 | \describe{ 120 | \item{\code{powerscale_plot_dens()}}{ Kernel density plot of 121 | power-scaled posterior draws with respect to power-scaling. } 122 | \item{\code{powerscale_plot_ecdf()}}{ Empirical cumulative 123 | distribution function plot of power-scaled posterior draws with 124 | respect to power-scaling. } 125 | \item{\code{powerscale_plot_quantities()}}{ Plot of posterior 126 | quantities with respect to power-scaling.} } 127 | } 128 | 129 | \examples{ 130 | ex <- example_powerscale_model() 131 | 132 | powerscale_plot_dens(ex$draws) 133 | } 134 | -------------------------------------------------------------------------------- /man/predictions_as_draws.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/brms-functions.R 3 | \name{predictions_as_draws} 4 | \alias{predictions_as_draws} 5 | \title{brms predictions as draws} 6 | \usage{ 7 | predictions_as_draws( 8 | x, 9 | predict_fn, 10 | prediction_names = NULL, 11 | warn_dims = getOption("priorsense.warn", TRUE), 12 | ... 13 | ) 14 | } 15 | \arguments{ 16 | \item{x}{brmsfit object} 17 | 18 | \item{predict_fn}{function for predictions} 19 | 20 | \item{prediction_names}{optional names of the predictions} 21 | 22 | \item{warn_dims}{throw a warning when coercing predict_fn's output from 3 23 | margins to 2 margins?} 24 | 25 | \item{...}{further arguments passed to predict_fn} 26 | } 27 | \value{ 28 | draws array of predictions 29 | } 30 | \description{ 31 | Create predictions using brms functions and convert them into 32 | draws format 33 | } 34 | \examples{ 35 | \dontrun{ 36 | library(brms) 37 | 38 | if ("log_prior_draws.brmsfit" \%in\% methods(log_prior_draws) && 39 | ("log_lik_draws.brmsfit" \%in\% methods(log_lik_draws))) { 40 | fit <- brm( 41 | yield ~ N * P * K, 42 | data = npk, 43 | prior = prior(normal(0, 1), class = "b"), 44 | refresh = 0 45 | ) 46 | 47 | powerscale_sensitivity( 48 | fit, 49 | variable = "_pred", 50 | prediction = function(x) predictions_as_draws( 51 | x, brms::posterior_epred 52 | ) 53 | ) 54 | } 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /man/priorsense-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/priorsense-package.R 3 | \docType{package} 4 | \name{priorsense-package} 5 | \alias{priorsense-package} 6 | \alias{priorsense} 7 | \title{priorsense: Prior (and likelihood) diagnostics and sensitivity 8 | analysis} 9 | \description{ 10 | The \pkg{priorsense} package provides functions for 11 | prior and likelihood sensitivity analysis of Bayesian 12 | models. Currently it implements methods to determine the 13 | sensitivity of the posterior to power-scaling perturbations of 14 | the prior and likelihood and is the first implementation of the 15 | method described in Kallioinen et al. (2023). 16 | } 17 | \details{ 18 | The main diagnostic function provided by \pkg{priorsense} 19 | is \code{\link{powerscale_sensitivity}}. Given a fitted model or 20 | draws object, it computes the powerscaling sensitivity diagnostic 21 | described in Kallioinen et al. (2023). It does so by perturbing 22 | the prior and likelihood and computing the effect on the 23 | posterior, without needing to refit the model (using Pareto 24 | smoothed importance sampling and importance weighted moment 25 | matching; Vehtari et al. 2022, Paananen et al. 2021). 26 | 27 | In addition, visual diagnostics are available by first using 28 | \code{\link{powerscale_sequence}} to create a sequence of perturbed 29 | posteriors, and then a plot function such as 30 | \code{\link{powerscale_plot_ecdf}} to visualise the change. 31 | 32 | The following global options are available: 33 | \itemize{ 34 | \item \code{priorsense.plot_help_text}: If \code{TRUE} (the default), priorsense plots will include a title and explanatory text. If \code{FALSE} they will not. 35 | \item \code{priorsense.plot_variables_per_page}: Number specifying the maximum number of variables to be plotted on one page of a plot. 36 | \item \code{priorsense.plot_ask}: If \code{TRUE} (the default), when multiple pages are plotted input is required before each subsequent page is rendered. 37 | If \code{FALSE} no input is required. 38 | } 39 | } 40 | \references{ 41 | Kallioinen, N., Paananen, T., Bürkner, P-C., Vehtari, A. (2023). 42 | Detecting and diagnosing prior and likelihood sensitivity with 43 | power-scaling perturbations. \emph{Statistics and 44 | Computing}. 34(57). \code{doi:10.1007/s11222-023-10366-5} 45 | 46 | Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, 47 | J. (2024). Pareto smoothed importance sampling. \emph{Journal of 48 | Machine Learning Research}. 25(72). 49 | \code{https://jmlr.org/papers/v25/19-556.html} 50 | 51 | Paananen, T., Piironen, J., Bürkner, P-C., Vehtari, A. (2021). 52 | Implicitly adaptive importance sampling. \emph{Statistics and 53 | Computing}. 31(16). \code{doi:10.1007/s11222-020-09982-2} 54 | } 55 | \seealso{ 56 | \code{\link{powerscale_sensitivity}} 57 | \code{\link{powerscale_sequence}} 58 | \code{\link{powerscale}} 59 | \code{\link{powerscale_plot_ecdf}} 60 | \code{\link{powerscale_plot_dens}} 61 | \code{\link{powerscale_plot_quantities}} 62 | } 63 | \author{ 64 | \strong{Maintainer}: Noa Kallioinen \email{noa.kallioinen@aalto.fi} [copyright holder] 65 | 66 | Authors: 67 | \itemize{ 68 | \item Topi Paananen 69 | \item Paul-Christian Bürkner 70 | \item Aki Vehtari 71 | } 72 | 73 | Other contributors: 74 | \itemize{ 75 | \item Frank Weber [contributor] 76 | } 77 | 78 | } 79 | -------------------------------------------------------------------------------- /priorsense.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | LineEndingConversion: Posix 18 | 19 | BuildType: Package 20 | PackageUseDevtools: Yes 21 | PackageInstallArgs: --no-multiarch --with-keep.source 22 | PackageRoxygenize: rd,collate,namespace 23 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(priorsense) 3 | 4 | test_check("priorsense") 5 | -------------------------------------------------------------------------------- /tests/testthat/test_cjs.R: -------------------------------------------------------------------------------- 1 | x <- c(1, 2, 3, 4) 2 | y <- c(4, 5, 6, 7) 3 | w <- c(0.1, 0.2, 0.3, 0.4) 4 | 5 | 6 | test_that("cjs works with one weighted", { 7 | expect_equal( 8 | cjs_dist(x, x, NULL, w), 9 | cjs_dist(x, x, w, NULL) 10 | ) 11 | }) 12 | 13 | #' @srrstats {EA6.0e} numeric value tested 14 | test_that("cjs works with different x and y", { 15 | expect_equal( 16 | cjs_dist(x, y, NULL, NULL), 17 | c(cjs = 0.5), 18 | tolerance = 0.1 19 | ) 20 | }) 21 | 22 | test_that("cjs returns zero for same x and y", { 23 | expect_equal( 24 | cjs_dist(x, x, NULL, NULL), 25 | c(cjs = 0) 26 | ) 27 | expect_equal( 28 | cjs_dist(x, x, w, w), 29 | c(cjs = 0) 30 | ) 31 | }) 32 | 33 | #' @srrstats {G5.8, G5.8b} complex input should give error 34 | test_that("cjs errors with complex and character input", { 35 | expect_error( 36 | cjs_dist(complex(1, 1, 1), complex(1, 1, 1)) 37 | ) 38 | expect_error( 39 | cjs_dist(c("a", "a", "a"), c("b", "b", "b")) 40 | ) 41 | } 42 | ) 43 | -------------------------------------------------------------------------------- /tests/testthat/test_cmdstan.R: -------------------------------------------------------------------------------- 1 | set.seed(123) 2 | normal_example <- example_powerscale_model("univariate_normal") 3 | 4 | test_that("powerscale functions work for CmdStanFit", { 5 | skip_on_cran() 6 | cs <- cmdstanr::cmdstan_model( 7 | stan_file = cmdstanr::write_stan_file(normal_example$model_code) 8 | ) 9 | 10 | cfit <- cs$sample( 11 | data = normal_example$data, 12 | refresh = 0, 13 | seed = 123, 14 | iter_sampling = 250, 15 | iter_warmup = 250, 16 | chains = 1 17 | ) 18 | expect_s3_class( 19 | create_priorsense_data( 20 | cfit 21 | ), 22 | "priorsense_data" 23 | ) 24 | expect_s3_class( 25 | powerscale( 26 | x = cfit, 27 | component = "prior", 28 | alpha = 0.8 29 | ), 30 | "powerscaled_draws" 31 | ) 32 | expect_s3_class( 33 | powerscale( 34 | x = cfit, 35 | component = "likelihood", 36 | alpha = 0.8 37 | ), 38 | "powerscaled_draws" 39 | ) 40 | expect_s3_class( 41 | suppressWarnings(powerscale_sequence( 42 | x = cfit 43 | )), 44 | "powerscaled_sequence" 45 | ) 46 | expect_s3_class( 47 | powerscale_sensitivity( 48 | x = cfit 49 | ), 50 | "powerscaled_sensitivity_summary" 51 | ) 52 | } 53 | ) 54 | 55 | -------------------------------------------------------------------------------- /tests/testthat/test_conjugate.R: -------------------------------------------------------------------------------- 1 | library(posterior) 2 | 3 | # test using a conjugate model with one parameter 4 | post <- function(tau, sigma, mu_0, n, x) { 5 | 6 | post_var <- 1/(n/sigma^2 + 1 /tau^2) 7 | 8 | xbar <- mean(x) 9 | post_mean <- post_var * (n * xbar / sigma^2 + mu_0 / tau^2) 10 | 11 | return(c(mean = post_mean, sd = sqrt(post_var))) 12 | 13 | } 14 | 15 | 16 | ll <- function(mu, x) { 17 | sum(dnorm(x = x, mean = mu, log = TRUE)) 18 | } 19 | 20 | #' @srrstats {G5.4a} Testing with simple model 21 | #' @srrstats {G5.5} Correctness tests run with a fixed random seed 22 | #' @srrstats {G5.6} Diagnostic is tested here in a model with no prior-data conflict and then with models with prior-data conflict 23 | #' @srrstats {G5.6a} Diagnostic value is tested with respect to the threshold of 0.05 24 | #' @srrstats {G5.7} Diagnostic value tested to increase as conflict increases 25 | test_that("powerscaling diagnostic makes sense for simple model", { 26 | 27 | set.seed(123) 28 | mu <- 0 29 | sigma <- 1 30 | 31 | n <- 50 32 | 33 | x <- rnorm(n = n, mean = mu, sd = sigma) 34 | 35 | # prior1 is mu ~ normal(0, 1) 36 | post1 <- post(1, sigma = sigma, mu_0 = 0, n = n, x = x) 37 | post1_draws <- as_draws_df(data.frame(mu = rnorm(4000, post1[["mean"]], post1[["sd"]]))) 38 | post1_loglik <- as_draws_df(data.frame(log_lik = vapply(post1_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 39 | post1_lprior <- as_draws_df(data.frame(lprior = dnorm(post1_draws$mu, mean = 0, log = TRUE))) 40 | psd1 <- create_priorsense_data(x = post1_draws, log_prior = post1_lprior, log_lik = post1_loglik) 41 | ps1 <- powerscale_sensitivity(psd1) 42 | 43 | # prior2 is mu ~ normal(5, 1) 44 | post2 <- post(1, sigma = sigma, mu_0 = 5, n = n, x = x) 45 | post2_draws <- as_draws_df(data.frame(mu = rnorm(4000, post2[["mean"]], post2[["sd"]]))) 46 | post2_loglik <- as_draws_df(data.frame(log_lik = vapply(post2_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 47 | post2_lprior <- as_draws_df(data.frame(lprior = dnorm(post2_draws$mu, mean = 5, log = TRUE))) 48 | psd2 <- create_priorsense_data(x = post2_draws, log_prior = post2_lprior, log_lik = post2_loglik) 49 | ps2 <- powerscale_sensitivity(psd2) 50 | 51 | # prior3 is mu ~ normal(10, 1) 52 | post3 <- post(1, sigma = sigma, mu_0 = 10, n = n, x = x) 53 | post3_draws <- as_draws_df(data.frame(mu = rnorm(4000, post3[["mean"]], post3[["sd"]]))) 54 | post3_loglik <- as_draws_df(data.frame(log_lik = vapply(post3_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 55 | post3_lprior <- as_draws_df(data.frame(lprior = dnorm(post3_draws$mu, mean = 10, log = TRUE))) 56 | psd3 <- create_priorsense_data(x = post3_draws, log_prior = post3_lprior, log_lik = post3_loglik) 57 | ps3 <- powerscale_sensitivity(psd3) 58 | 59 | # expect conflict to show up as above threshold 60 | expect_lt(ps1$prior, 0.05) 61 | expect_gt(ps2$prior, 0.05) 62 | expect_gt(ps3$prior, 0.05) 63 | 64 | # expect all models to have likelihood sensitivity 65 | expect_gt(ps1$likelihood, 0.05) 66 | expect_gt(ps2$likelihood, 0.05) 67 | expect_gt(ps3$likelihood, 0.05) 68 | 69 | # expect sensitivity to increase as conflict increases 70 | expect_lt(ps1$prior, ps2$prior) 71 | expect_lt(ps2$prior, ps3$prior) 72 | expect_lt(ps1$likelihood, ps2$likelihood) 73 | expect_lt(ps2$likelihood, ps3$likelihood) 74 | 75 | } 76 | ) 77 | 78 | 79 | #' @srrstats {G5.6b} Multiple seeds tested here 80 | #' @srrstats {G5.9} Several seeds tested here 81 | #' @srrstats {G5.9b} Several seeds tested here and results tested to follow similar pattern 82 | test_that("powerscaling diagnostic makes sense for simple model with different seeds", { 83 | 84 | set.seed(456) 85 | mu <- 0 86 | sigma <- 1 87 | n <- 50 88 | x <- rnorm(n = n, mean = mu, sd = sigma) 89 | 90 | # prior1 is mu ~ normal(0, 1) 91 | post1 <- post(1, sigma = sigma, mu_0 = 0, n = n, x = x) 92 | post1_draws <- as_draws_df(data.frame(mu = rnorm(4000, post1[["mean"]], post1[["sd"]]))) 93 | post1_loglik <- as_draws_df(data.frame(log_lik = vapply(post1_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 94 | post1_lprior <- as_draws_df(data.frame(lprior = dnorm(post1_draws$mu, mean = 0, log = TRUE))) 95 | psd1 <- create_priorsense_data(x = post1_draws, log_prior = post1_lprior, log_lik = post1_loglik) 96 | ps1 <- powerscale_sensitivity(psd1) 97 | 98 | # prior2 is mu ~ normal(5, 1) 99 | post2 <- post(1, sigma = sigma, mu_0 = 5, n = n, x = x) 100 | post2_draws <- as_draws_df(data.frame(mu = rnorm(4000, post2[["mean"]], post2[["sd"]]))) 101 | post2_loglik <- as_draws_df(data.frame(log_lik = vapply(post2_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 102 | post2_lprior <- as_draws_df(data.frame(lprior = dnorm(post2_draws$mu, mean = 5, log = TRUE))) 103 | psd2 <- create_priorsense_data(x = post2_draws, log_prior = post2_lprior, log_lik = post2_loglik) 104 | ps2 <- powerscale_sensitivity(psd2) 105 | 106 | # prior3 is mu ~ normal(10, 1) 107 | post3 <- post(1, sigma = sigma, mu_0 = 10, n = n, x = x) 108 | post3_draws <- as_draws_df(data.frame(mu = rnorm(4000, post3[["mean"]], post3[["sd"]]))) 109 | post3_loglik <- as_draws_df(data.frame(log_lik = vapply(post3_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 110 | post3_lprior <- as_draws_df(data.frame(lprior = dnorm(post3_draws$mu, mean = 10, log = TRUE))) 111 | psd3 <- create_priorsense_data(x = post3_draws, log_prior = post3_lprior, log_lik = post3_loglik) 112 | ps3 <- powerscale_sensitivity(psd3) 113 | 114 | # expect conflict to show up as above threshold 115 | expect_lt(ps1$prior, 0.05) 116 | expect_gt(ps2$prior, 0.05) 117 | expect_gt(ps3$prior, 0.05) 118 | 119 | # expect all models to have likelihood sensitivity 120 | expect_gt(ps1$likelihood, 0.05) 121 | expect_gt(ps2$likelihood, 0.05) 122 | expect_gt(ps3$likelihood, 0.05) 123 | 124 | # expect sensitivity to increase as conflict increases 125 | expect_lt(ps1$prior, ps2$prior) 126 | expect_lt(ps2$prior, ps3$prior) 127 | expect_lt(ps1$likelihood, ps2$likelihood) 128 | expect_lt(ps2$likelihood, ps3$likelihood) 129 | 130 | # another seed 131 | set.seed(789) 132 | mu <- 0 133 | sigma <- 1 134 | n <- 50 135 | x <- rnorm(n = n, mean = mu, sd = sigma) 136 | 137 | # prior1 is mu ~ normal(0, 1) 138 | post1 <- post(1, sigma = sigma, mu_0 = 0, n = n, x = x) 139 | post1_draws <- as_draws_df(data.frame(mu = rnorm(4000, post1[["mean"]], post1[["sd"]]))) 140 | post1_loglik <- as_draws_df(data.frame(log_lik = vapply(post1_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 141 | post1_lprior <- as_draws_df(data.frame(lprior = dnorm(post1_draws$mu, mean = 0, log = TRUE))) 142 | psd1 <- create_priorsense_data(x = post1_draws, log_prior = post1_lprior, log_lik = post1_loglik) 143 | ps1 <- powerscale_sensitivity(psd1) 144 | 145 | # prior2 is mu ~ normal(5, 1) 146 | post2 <- post(1, sigma = sigma, mu_0 = 5, n = n, x = x) 147 | post2_draws <- as_draws_df(data.frame(mu = rnorm(4000, post2[["mean"]], post2[["sd"]]))) 148 | post2_loglik <- as_draws_df(data.frame(log_lik = vapply(post2_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 149 | post2_lprior <- as_draws_df(data.frame(lprior = dnorm(post2_draws$mu, mean = 5, log = TRUE))) 150 | psd2 <- create_priorsense_data(x = post2_draws, log_prior = post2_lprior, log_lik = post2_loglik) 151 | ps2 <- powerscale_sensitivity(psd2) 152 | 153 | # prior3 is mu ~ normal(10, 1) 154 | post3 <- post(1, sigma = sigma, mu_0 = 10, n = n, x = x) 155 | post3_draws <- as_draws_df(data.frame(mu = rnorm(4000, post3[["mean"]], post3[["sd"]]))) 156 | post3_loglik <- as_draws_df(data.frame(log_lik = vapply(post3_draws$mu, FUN = ll, FUN.VALUE = c(1), x = x))) 157 | post3_lprior <- as_draws_df(data.frame(lprior = dnorm(post3_draws$mu, mean = 10, log = TRUE))) 158 | psd3 <- create_priorsense_data(x = post3_draws, log_prior = post3_lprior, log_lik = post3_loglik) 159 | ps3 <- powerscale_sensitivity(psd3) 160 | 161 | # expect conflict to show up as above threshold 162 | expect_lt(ps1$prior, 0.05) 163 | expect_gt(ps2$prior, 0.05) 164 | expect_gt(ps3$prior, 0.05) 165 | 166 | # expect all models to have likelihood sensitivity 167 | expect_gt(ps1$likelihood, 0.05) 168 | expect_gt(ps2$likelihood, 0.05) 169 | expect_gt(ps3$likelihood, 0.05) 170 | 171 | # expect sensitivity to increase as conflict increases 172 | expect_lt(ps1$prior, ps2$prior) 173 | expect_lt(ps2$prior, ps3$prior) 174 | expect_lt(ps1$likelihood, ps2$likelihood) 175 | expect_lt(ps2$likelihood, ps3$likelihood) 176 | } 177 | ) 178 | -------------------------------------------------------------------------------- /tests/testthat/test_deriv.R: -------------------------------------------------------------------------------- 1 | library(priorsense) 2 | 3 | test_that("powerscale_derivative gives 0 for uniform log_component", { 4 | expect_equal( 5 | priorsense::powerscale_derivative( 6 | x = seq(0, 1, 0.01), 7 | log_component = log(rep( 8 | 1 / length(seq(0, 1, 0.01)), 9 | length(seq(0, 1, 0.01)) 10 | )), 11 | quantity = "mean"), 12 | c(psens_mean = 0) 13 | ) 14 | expect_equal( 15 | priorsense::powerscale_derivative( 16 | x = seq(0, 1, 0.01), 17 | log_component = log(rep( 18 | 1 / length(seq(0, 1, 0.01)), 19 | length(seq(0, 1, 0.01)) 20 | )), 21 | quantity = "sd"), 22 | c(psens_sd = 0) 23 | ) 24 | expect_equal( 25 | priorsense::powerscale_derivative( 26 | x = seq(0, 1, 0.01), 27 | log_component = log(rep( 28 | 1 / length(seq(0, 1, 0.01)), 29 | length(seq(0, 1, 0.01)) 30 | )), 31 | quantity = "var"), 32 | c(psens_var = 0) 33 | ) 34 | }) 35 | 36 | 37 | #' @srrstats {G5.2a, G5.2b} warning messages checked here 38 | test_that("powerscale_derivative gives warning if not using mean, sd or var", { 39 | expect_warning( 40 | priorsense::powerscale_derivative( 41 | x = seq(0, 1, 0.01), 42 | log_component = log(1 + seq(0, 1, 0.01)), 43 | quantity = "median"), 44 | "Power-scaling derivative for medians or quantiles is zero. Consider using powerscale_gradients instead." 45 | ) 46 | expect_warning( 47 | priorsense::powerscale_derivative( 48 | x = seq(0, 1, 0.01), 49 | log_component = log(1 + seq(0, 1, 0.01)), 50 | quantity = "q95"), 51 | "Power-scaling derivative for medians or quantiles is zero. Consider using powerscale_gradients instead." 52 | ) 53 | expect_warning( 54 | priorsense::powerscale_derivative( 55 | x = seq(0, 1, 0.01), 56 | log_component = log(1 + seq(0, 1, 0.01)), 57 | quantity = "mad"), 58 | "Power-scaling derivative for medians or quantiles is zero. Consider using powerscale_gradients instead." 59 | ) 60 | }) 61 | -------------------------------------------------------------------------------- /tests/testthat/test_div_measures.R: -------------------------------------------------------------------------------- 1 | div_measures <- c("js_div", "js_dist", "hellinger_dist", "kl_div", "kl_dist", "ks_dist", "ws_dist") 2 | 3 | psd <- create_priorsense_data(example_powerscale_model()$draws) 4 | 5 | test_that("divergence measures do not error", { 6 | 7 | for (d in div_measures) { 8 | expect_no_error( 9 | suppressWarnings( 10 | powerscale_sensitivity( 11 | psd, 12 | div_measure = d 13 | ) 14 | ) 15 | ) 16 | } 17 | } 18 | ) 19 | -------------------------------------------------------------------------------- /tests/testthat/test_moment_matching.R: -------------------------------------------------------------------------------- 1 | set.seed(123) 2 | normal_example <- example_powerscale_model("univariate_normal") 3 | 4 | sfit <- suppressWarnings(rstan::stan( 5 | model_code = normal_example$model_code, 6 | data = normal_example$data, 7 | refresh = FALSE, 8 | seed = 123, 9 | iter = 500, 10 | warmup = 250, 11 | chains = 4 12 | )) 13 | 14 | test_that("moment matching is applied when specified and pareto-k is higher than threshold", { 15 | skip_on_cran() 16 | expect_true( 17 | get_powerscaling_details( 18 | powerscale( 19 | x = sfit, 20 | alpha = 0.2, 21 | component = "likelihood", 22 | moment_match = TRUE 23 | ) 24 | )$moment_match 25 | ) 26 | }) 27 | -------------------------------------------------------------------------------- /tests/testthat/test_plots.R: -------------------------------------------------------------------------------- 1 | eight_schools_example <- example_powerscale_model("eight_schools") 2 | 3 | ps <- powerscale_sequence(eight_schools_example$draws, length = 3) 4 | 5 | test_that("diagnostic plots give no errors", { 6 | expect_error( 7 | powerscale_plot_ecdf( 8 | ps, 9 | variable = c("mu", "tau") 10 | ), 11 | NA 12 | ) 13 | expect_error( 14 | powerscale_plot_dens( 15 | x = ps, 16 | variable = c("mu", "tau") 17 | ), 18 | NA 19 | ) 20 | expect_error( 21 | powerscale_plot_quantities( 22 | ps, 23 | variable = c("mu", "tau") 24 | ), 25 | NA 26 | ) 27 | }) 28 | 29 | test_that("plots contain expected data", { 30 | psq <- powerscale_plot_quantities( 31 | ps, 32 | variable = c("mu"), 33 | quantity = c("quantile", "mean"), 34 | quantity_args = list(probs = c(0.1, 0.9)) 35 | ) 36 | expect_equal( 37 | colnames(psq$data), 38 | c("variable", ".powerscale_alpha", "pareto_k_threshold", 39 | "pareto_k", "component", "quantity", "value", "id", "pareto_k_value") 40 | ) 41 | 42 | expect_equal( 43 | unique(psq$data$quantity), 44 | c("q10", "q90", "mean", "cjs_dist") 45 | ) 46 | }) 47 | 48 | 49 | test_that("help_text behaves as expected in plots", { 50 | 51 | psq_title <- powerscale_plot_quantities( 52 | ps, 53 | variable = c("mu"), 54 | help_text = TRUE 55 | ) 56 | 57 | psq_notitle <- powerscale_plot_quantities( 58 | ps, 59 | variable = c("mu"), 60 | help_text = FALSE 61 | ) 62 | 63 | expect_false(is.null(psq_title$labels$title)) 64 | expect_false(is.null(psq_title$labels$subtitle)) 65 | 66 | expect_null(psq_notitle$labels$title) 67 | expect_null(psq_notitle$labels$subtitle) 68 | 69 | psecdf_title <- powerscale_plot_ecdf(ps, variable = "mu") 70 | 71 | psecdf_notitle <- powerscale_plot_ecdf(ps, variable = "mu", help_text = FALSE) 72 | 73 | 74 | expect_false(is.null(psecdf_title$labels$title)) 75 | expect_false(is.null(psecdf_title$labels$subtitle)) 76 | 77 | expect_null(psecdf_notitle$labels$title) 78 | expect_null(psecdf_notitle$labels$subtitle) 79 | 80 | psdens_title <- powerscale_plot_dens(ps, variable = "mu") 81 | psdens_notitle <- powerscale_plot_dens(ps, variable = "mu", help_text = FALSE) 82 | 83 | expect_false(is.null(psdens_title$labels$title)) 84 | expect_false(is.null(psdens_title$labels$subtitle)) 85 | 86 | expect_null(psdens_notitle$labels$title) 87 | expect_null(psdens_notitle$labels$subtitle) 88 | }) 89 | 90 | test_that("pagination of plots works as expected", { 91 | 92 | expect_length( 93 | powerscale_plot_quantities( 94 | ps, 95 | variables_per_page = 1 96 | ), 18) 97 | 98 | expect_length( 99 | powerscale_plot_quantities( 100 | ps, 101 | variables_per_page = 2 102 | ), 9) 103 | 104 | expect_length( 105 | powerscale_plot_quantities( 106 | ps, 107 | variables_per_page = Inf 108 | ), 11) 109 | }) 110 | 111 | 112 | 113 | #' @srrstats {EA6.1} vdiffr used for all types of plots 114 | ps_normal <- powerscale_sequence(example_powerscale_model()$draws) 115 | 116 | vdiffr::expect_doppelganger( 117 | "Normal model density plot", 118 | powerscale_plot_dens(ps_normal) 119 | ) 120 | 121 | 122 | vdiffr::expect_doppelganger( 123 | "Normal model ecdf plot", 124 | powerscale_plot_ecdf(ps_normal) 125 | ) 126 | 127 | vdiffr::expect_doppelganger( 128 | "Normal model quantities plot", 129 | powerscale_plot_quantities(ps_normal) 130 | ) 131 | -------------------------------------------------------------------------------- /tests/testthat/test_powerscale.R: -------------------------------------------------------------------------------- 1 | #' @srrstats {EA6.0} return values are tested in tests 2 | 3 | univariate_normal_draws <- example_powerscale_model()$draws 4 | 5 | #' @srrstats {EA4.0} output type tested 6 | test_that("priorsense_data is created", { 7 | expect_s3_class( 8 | create_priorsense_data( 9 | univariate_normal_draws 10 | ), 11 | "priorsense_data" 12 | ) 13 | } 14 | ) 15 | 16 | #' @srrstats {G5.3} Missing values tested 17 | #' @srrstats {EA4.0} output type tested 18 | test_that("powerscale returns powerscaled_draws with no missing values", { 19 | psp <- powerscale( 20 | x = univariate_normal_draws, 21 | component = "prior", 22 | alpha = 0.8 23 | ) 24 | expect_s3_class( 25 | psp, 26 | "powerscaled_draws" 27 | ) 28 | expect_false(checkmate::anyMissing(psp)) 29 | 30 | psl <- powerscale( 31 | x = univariate_normal_draws, 32 | component = "likelihood", 33 | alpha = 0.8 34 | ) 35 | 36 | expect_s3_class( 37 | psl, 38 | "powerscaled_draws" 39 | ) 40 | expect_false(checkmate::anyMissing(psp)) 41 | 42 | } 43 | ) 44 | 45 | #' @srrstats {EA4.0} output type tested 46 | test_that("powerscale_seqence returns powerscaled_sequence", { 47 | expect_s3_class( 48 | suppressWarnings(powerscale_sequence( 49 | x = univariate_normal_draws 50 | )), 51 | "powerscaled_sequence" 52 | ) 53 | } 54 | ) 55 | 56 | #' @srrstats {EA6.0a} classes tested 57 | #' @srrstats {EA6.0b} dimensions tested 58 | #' @srrstats {EA6.0c} column names tested 59 | #' @srrstats {EA6.0d} classes of columns tested 60 | test_that("powerscale_sensitivity returns powerscaled_sensitivity_summary with expected columns", { 61 | ps <- powerscale_sensitivity( 62 | x = univariate_normal_draws 63 | ) 64 | expect_s3_class(ps 65 | , 66 | "powerscaled_sensitivity_summary" 67 | ) 68 | 69 | expect_equal(dim(ps), c(2, 4)) 70 | 71 | expect_identical(colnames(ps), c("variable", "prior", "likelihood", "diagnosis")) 72 | expect_vector(ps[["variable"]], ptype = character()) 73 | expect_vector(ps[["prior"]], ptype = numeric()) 74 | expect_vector(ps[["likelihood"]], ptype = numeric()) 75 | expect_vector(ps[["diagnosis"]], ptype = character()) 76 | } 77 | ) 78 | 79 | test_that("powerscale_sequence uses input alphas correctly", { 80 | 81 | lower_alpha <- 0.5 82 | upper_alpha <- 2.5 83 | pss <- suppressWarnings(powerscale_sequence( 84 | x = univariate_normal_draws, 85 | lower_alpha = lower_alpha, 86 | upper_alpha = upper_alpha, 87 | symmetric = FALSE, 88 | length = 10 89 | )) 90 | 91 | expect_equal( 92 | pss$alphas[1], 93 | 0.5 94 | ) 95 | 96 | expect_equal( 97 | get_powerscaling_details(pss$prior_scaled$draws_sequence[[1]])$alpha, 98 | 0.5 99 | ) 100 | 101 | expect_equal( 102 | pss$alphas[length(pss$alphas)], 103 | 2.5 104 | ) 105 | 106 | expect_equal( 107 | get_powerscaling_details( 108 | pss$prior_scaled$draws_sequence[[length(pss$alphas)]] 109 | )$alpha, 110 | 2.5 111 | ) 112 | 113 | expect_equal( 114 | length(pss$alphas), 115 | 10 116 | ) 117 | 118 | } 119 | ) 120 | 121 | test_that("powerscale_sequence adapts alphas and keeps pareto-k low", { 122 | k_threshold <- 0.7 123 | pss <- suppressWarnings(powerscale_sequence( 124 | x = univariate_normal_draws, 125 | auto_alpha_range = TRUE 126 | )) 127 | 128 | expect_lt( 129 | get_powerscaling_details( 130 | pss$likelihood_scaled$draws_sequence[[1]] 131 | )$diagnostics$khat, 132 | k_threshold 133 | ) 134 | 135 | expect_lt( 136 | get_powerscaling_details( 137 | pss$likelihood_scaled$draws_sequence[[length( 138 | pss$likelihood_scaled$draws_sequence)]] 139 | )$diagnostics$khat, 140 | k_threshold 141 | ) 142 | 143 | expect_lt( 144 | attr(pss$prior_scaled$draws_sequence[[1]], "powerscaling")$diagnostics$khat, 145 | k_threshold 146 | ) 147 | 148 | expect_lt( 149 | get_powerscaling_details(pss$prior_scaled$draws_sequence[[ 150 | length(pss$prior_scaled$draws_sequence)]] 151 | )$diagnostics$khat, 152 | k_threshold 153 | ) 154 | 155 | } 156 | ) 157 | 158 | test_that("powerscale_sequence gives symmetric range", { 159 | 160 | lower_alpha <- 0.3 161 | length <- 9 162 | pss <- suppressWarnings(powerscale_sequence( 163 | x = univariate_normal_draws, 164 | symmetric = TRUE, 165 | lower_alpha = lower_alpha, 166 | length = length 167 | )) 168 | 169 | expect_equal( 170 | pss$alphas[1], 171 | lower_alpha 172 | ) 173 | 174 | expect_equal( 175 | get_powerscaling_details(pss$prior_scaled$draws_sequence[[1]])$alpha, 176 | lower_alpha 177 | ) 178 | 179 | expect_equal( 180 | pss$alphas[length(pss$alphas)], 181 | 1 / lower_alpha 182 | ) 183 | 184 | expect_equal( 185 | get_powerscaling_details(pss$prior_scaled$draws_sequence[[ 186 | length(pss$alphas)]])$alpha, 187 | 1 / lower_alpha 188 | ) 189 | 190 | expect_equal( 191 | length(pss$alphas), 192 | 8 193 | ) 194 | 195 | expect_equal( 196 | abs(log(pss$alphas[1])), 197 | abs(log(pss$alphas[length(pss$alphas)])) 198 | ) 199 | 200 | } 201 | ) 202 | 203 | #' @srrstats {G5.9a} Adding trivial noise to data does not 204 | #' meaningfully change results* 205 | test_that("small variation in draws does not affect result", { 206 | 207 | adjusted_draws <- univariate_normal_draws + .Machine$double.eps 208 | 209 | orig_ps <- powerscale_sensitivity(univariate_normal_draws) 210 | adjusted_ps <- powerscale_sensitivity(adjusted_draws) 211 | 212 | expect_equal(orig_ps, adjusted_ps) 213 | } 214 | ) 215 | 216 | 217 | #' @srrstats {G5.2} error behaviour tested here 218 | #' @srrstats {G5.8, G5.8d} test edge case out of scope 219 | test_that("powerscaling with alpha < 0 is an error", { 220 | expect_error(powerscale(univariate_normal_draws, 221 | component = "prior", 222 | alpha = -1)) 223 | } 224 | ) 225 | 226 | #' @srrstats {G5.8, G5.8a} test edge case zero-length data 227 | test_that("powerscaling zero draws is an error", { 228 | zero_draws <- data.frame( 229 | mu = numeric(), 230 | log_lik = numeric(), 231 | lprior = numeric() 232 | ) 233 | expect_error(powerscale(zero_draws, component = "prior", alpha = 0.1)) 234 | } 235 | ) 236 | 237 | #' @srrstats {G5.2a, G5.2b, G5.8b} constant weights unsupported and 238 | #' give explicit error message 239 | test_that("powerscaling with constant loglik is an error", { 240 | const_draws <- data.frame( 241 | mu = 1:100, 242 | log_lik = rep(1, times = 100), 243 | lprior = 1:100 244 | ) 245 | expect_error(powerscale(const_draws, component = "likelihood", alpha = 0.1), 246 | paste0("Log likelihood is constant. ", 247 | "Power-scaling will not work in this case" 248 | ) 249 | ) 250 | } 251 | ) 252 | 253 | test_that("powerscaling with constant lprior is an error", { 254 | const_draws <- data.frame( 255 | mu = 1:100, 256 | lprior = rep(1, times = 100), 257 | log_lik = 1:100 258 | ) 259 | expect_error(powerscale(const_draws, component = "prior", alpha = 0.1), 260 | paste0( 261 | "Log prior is constant. ", 262 | "Power-scaling will not work in this case" 263 | ) 264 | ) 265 | } 266 | ) 267 | 268 | #' @srrstats {G5.8, G5.8c} test edge case with NAs 269 | test_that("powerscaling with NA weights is an error", { 270 | na_draws <- data.frame( 271 | mu = 1:100, 272 | log_lik = rep(NA, times = 100), 273 | lprior = 1:100 274 | ) 275 | expect_error(powerscale(na_draws, component = "likelihood", alpha = 0.1)) 276 | } 277 | ) 278 | -------------------------------------------------------------------------------- /tests/testthat/test_print.R: -------------------------------------------------------------------------------- 1 | psd <- create_priorsense_data(example_powerscale_model()$draws) 2 | 3 | 4 | test_that("print methods provide output", { 5 | 6 | ps <- powerscale_sensitivity(psd) 7 | expect_output(print(ps)) 8 | 9 | ps_drw <- powerscale(psd, "prior", 0.5) 10 | expect_output(print(ps_drw)) 11 | 12 | ps_summ <- summarise_draws(ps_drw) 13 | expect_output(print(ps_summ)) 14 | 15 | pss <- powerscale_sequence(psd) 16 | expect_output(print(pss)) 17 | 18 | w <- whiten_draws(posterior::example_draws()) 19 | expect_output(print(w)) 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/test_resample.R: -------------------------------------------------------------------------------- 1 | set.seed(123) 2 | normal_example <- example_powerscale_model("univariate_normal") 3 | 4 | sfit <- suppressWarnings(rstan::stan( 5 | model_code = normal_example$model_code, 6 | data = c(normal_example$data, prior_alpha = 1, likelihood_alpha = 1), 7 | refresh = FALSE, 8 | seed = 123, 9 | iter = 1000, 10 | warmup = 250, 11 | chains = 1 12 | )) 13 | 14 | test_that("powerscale with resample actually resamples", { 15 | 16 | ps <- powerscale( 17 | x = sfit, 18 | component = "prior", 19 | alpha = 0.5, 20 | resample = TRUE 21 | ) 22 | 23 | expect_equal( 24 | get_powerscaling_details(ps)$resampled, 25 | TRUE 26 | ) 27 | 28 | expect_equal( 29 | stats::weights(ps), 30 | NULL 31 | ) 32 | }) 33 | 34 | 35 | test_that("powerscale_sequence with resample actually resamples", { 36 | 37 | pss <- suppressWarnings(powerscale_sequence( 38 | x = sfit, 39 | variables = c("mu"), 40 | resample = TRUE, 41 | )) 42 | expect_equal( 43 | pss$resampled, 44 | TRUE 45 | ) 46 | expect_equal( 47 | stats::weights(pss$prior_scaled$draws_sequence[[1]]) 48 | , 49 | NULL 50 | ) 51 | }) 52 | -------------------------------------------------------------------------------- /tests/testthat/test_rstan.R: -------------------------------------------------------------------------------- 1 | #' @srrstats {G5.0} eight schools is a well-established example for 2 | #' Bayesian models 3 | set.seed(123) 4 | eight_schools_example <- example_powerscale_model("eight_schools") 5 | sfit <- rstan::stan( 6 | model_code = eight_schools_example$model_code, 7 | data = eight_schools_example$data, 8 | refresh = FALSE, 9 | seed = 123 10 | ) 11 | 12 | test_that("priorsense_data is created", { 13 | expect_s3_class( 14 | create_priorsense_data( 15 | sfit 16 | ), 17 | "priorsense_data" 18 | ) 19 | } 20 | ) 21 | 22 | test_that("powerscale returns powerscaled_draws", { 23 | expect_s3_class( 24 | powerscale( 25 | x = sfit, 26 | component = "prior", 27 | alpha = 0.8 28 | ), 29 | "powerscaled_draws" 30 | ) 31 | expect_s3_class( 32 | powerscale( 33 | x = sfit, 34 | component = "likelihood", 35 | alpha = 0.8 36 | ), 37 | "powerscaled_draws" 38 | ) 39 | } 40 | ) 41 | 42 | test_that("powerscale_seqence returns powerscaled_sequence", { 43 | expect_s3_class(powerscale_sequence( 44 | x = sfit 45 | ), 46 | "powerscaled_sequence" 47 | ) 48 | } 49 | ) 50 | 51 | test_that("powerscale_sensitivity returns powerscaled_sensitivity_summary", { 52 | expect_s3_class( 53 | powerscale_sensitivity( 54 | x = sfit 55 | ), 56 | "powerscaled_sensitivity_summary" 57 | ) 58 | } 59 | ) 60 | -------------------------------------------------------------------------------- /tests/testthat/test_scale_draws.R: -------------------------------------------------------------------------------- 1 | test_that("scale draws returns draws object", { 2 | 3 | ex_drw <- posterior::example_draws() 4 | 5 | s_drw <- scale_draws(ex_drw) 6 | 7 | expect_s3_class(s_drw, "draws") 8 | 9 | } 10 | ) 11 | -------------------------------------------------------------------------------- /tests/testthat/test_weighted.R: -------------------------------------------------------------------------------- 1 | x <- c(1, 2, 3, 4, 5) 2 | w <- rep(1, length(x)) 3 | w <- w / sum(w) 4 | 5 | test_that("weighted quantities work when weights are 1", { 6 | expect_equal( 7 | median_weighted(x = x, weights = w), 8 | c(median = median(x)) 9 | ) 10 | expect_equal( 11 | mean_weighted(x = x, weights = w), 12 | c(mean = mean(x)) 13 | ) 14 | expect_equal( 15 | sd_weighted(x = x, weights = w), 16 | c(sd = sd(x)) 17 | ) 18 | expect_equal( 19 | mad_weighted(x = x, weights = w), 20 | c(mad = mad(x)) 21 | ) 22 | expect_equal( 23 | var_weighted(x = x, weights = w), 24 | c(var = var(x)) 25 | ) 26 | expect_equal( 27 | quantile_weighted(x = x, weights = w), 28 | posterior::quantile2(x = x) 29 | ) 30 | }) 31 | -------------------------------------------------------------------------------- /tests/testthat/test_whiten_draws.R: -------------------------------------------------------------------------------- 1 | test_that("whiten draws returns expected structure", { 2 | 3 | ex_drw <- posterior::example_draws() 4 | 5 | w_drw <- whiten_draws(ex_drw) 6 | 7 | expect_s3_class(w_drw, "whitened_draws") 8 | expect_s3_class(w_drw, "draws") 9 | 10 | expect_equal(names(attributes(w_drw)), 11 | c("names", "row.names", "class", "loadings")) 12 | 13 | expect_true(is.matrix(attr(w_drw, "loadings"))) 14 | } 15 | ) 16 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | 4 | /.quarto/ 5 | -------------------------------------------------------------------------------- /vignettes/powerscaling.qmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Power-scaling sensitivity analysis" 3 | vignette: > 4 | %\VignetteIndexEntry{Power-scaling sensitivity analysis} 5 | %\VignetteEngine{quarto::html} 6 | %\VignetteEncoding{UTF-8} 7 | --- 8 | 9 | ```{r, include = FALSE} 10 | 11 | ggplot2::theme_set(bayesplot::theme_default(base_family = "sans")) 12 | ``` 13 | 14 | # Introduction 15 | 16 | priorsense is a package for prior diagnostics in Bayesian models. It 17 | currently implements power-scaling sensitivity analysis but may be 18 | extended in the future to include other diagnostics. 19 | 20 | # Power-scaling sensitivity analysis 21 | 22 | Power-scaling sensitivity analysis tries to determine how small 23 | changes to the prior or likelihood affect the posterior. This is done 24 | by power-scaling the prior or likelihood by raising it to some $\alpha > 0$. 25 | 26 | - For prior power-scaling: $p(\theta \mid y) \propto p(\theta)^\alpha 27 | p(y \mid \theta)$ 28 | - For likelihood power-scaling: $p(\theta \mid y) \propto 29 | p(\theta) p(y \mid \theta)^\alpha$ 30 | 31 | In priorsense, this is done in a computationally efficient manner 32 | using Pareto-smoothed importance sampling (and optionally importance 33 | weighted moment matching) to estimate properties of these perturbed 34 | posteriors. Sensitivity can then be quantified by considering how much 35 | the perturbed posteriors differ from the base posterior. 36 | 37 | ## Example power-scaling sensitivity analysis 38 | ```{r} 39 | #| warning: false 40 | library(priorsense) 41 | library(rstan) 42 | ``` 43 | 44 | Consider the following model (available via 45 | `example_powerscale_model("univariate_normal")`: 46 | 47 | $$y \sim \text{normal}(\mu, \sigma)$$ 48 | $$\mu \sim \text{normal}(0, 1)$$ 49 | $$\sigma \sim \text{normal}^+(0, 2.5)$$ 50 | 51 | We have 100 data points for $y$ 52 | We first fit the model using Stan: 53 | 54 | ```stan 55 | data { 56 | int N; 57 | array[N] real y; 58 | } 59 | parameters { 60 | real mu; 61 | real sigma; 62 | } 63 | model { 64 | // priors 65 | target += normal_lpdf(mu | 0, 1); 66 | target += normal_lpdf(sigma | 0, 2.5); 67 | // likelihood 68 | target += normal_lpdf(y | mu, sigma); 69 | } 70 | generated quantities { 71 | vector[N] log_lik; 72 | real lprior; 73 | // log likelihood 74 | for (n in 1:N) log_lik[n] = normal_lpdf(y[n] | mu, sigma); 75 | // joint log prior 76 | lprior = normal_lpdf(mu | 0, 1) + normal_lpdf(sigma | 0, 2.5); 77 | } 78 | ``` 79 | 80 | ```{r} 81 | #| warning: false 82 | #| eval: false 83 | #| message: false 84 | normal_model <- example_powerscale_model("univariate_normal") 85 | 86 | fit <- stan( 87 | model_code = normal_model$model_code, 88 | data = normal_model$data, 89 | refresh = FALSE, 90 | seed = 123 91 | ) 92 | 93 | ``` 94 | 95 | ```{r} 96 | #| echo: false 97 | #| warning: false 98 | #| message: false 99 | normal_model <- example_powerscale_model("univariate_normal") 100 | fit <- normal_model$draws 101 | 102 | ``` 103 | 104 | Next, we check the sensitivity of the prior and likelihood to 105 | power-scaling. The sensitivity values shown below are an indication of 106 | how much the posterior changes with respect to power-scaling. Larger 107 | values indicate more sensitivity. By default these values are derived 108 | from the gradient of the Cumulative Jensen-Shannon distance between 109 | the base posterior and posteriors resulting from power-scaling. 110 | 111 | ```{r} 112 | #| message: false 113 | #| warning: false 114 | powerscale_sensitivity(fit, variable = c("mu", "sigma")) 115 | ``` 116 | 117 | Here, we see that the pattern of sensitivity indicates that there is 118 | prior-data conflict for $\mu$. We follow up with visualisation. 119 | 120 | We first create a `powerscaled_sequence` object, which contains 121 | estimates of posteriors for a range of power-scaling amounts. 122 | 123 | There are three plots currently available: 124 | 125 | - Kernel density estimates: 126 | ```{r} 127 | #| message: false 128 | #| warning: false 129 | #| fig-width: 6 130 | #| fig-height: 4 131 | powerscale_plot_dens(fit, variable = "mu", facet_rows = "variable") 132 | ``` 133 | 134 | - Empirical cumulative distribution functions: 135 | ```{r} 136 | #| message: false 137 | #| warning: false 138 | #| fig-width: 6 139 | #| fig-height: 4 140 | powerscale_plot_ecdf(fit, variable = "mu", facet_rows = "variable") 141 | ``` 142 | 143 | - Quantities: 144 | ```{r} 145 | #| message: false 146 | #| warning: false 147 | #| fig-width: 12 148 | #| fig-height: 4 149 | powerscale_plot_quantities(fit, variable = "mu") 150 | ``` 151 | 152 | As can be seen in the plots, power-scaling the prior and likelihood 153 | have opposite direction effects on the posterior. This is further 154 | evidence of prior-data conflict. 155 | 156 | Indeed, if we inspect the raw data, we see that the prior on $\mu$, 157 | $\text{normal}(0, 1)$ does not match well with the mean of the data, 158 | whereas the prior on $\sigma$, $\text{normal}^+(0, 2.5)$ is 159 | reasonable: 160 | 161 | ```{r} 162 | mean(normal_model$data$y) 163 | sd(normal_model$data$y) 164 | ``` 165 | -------------------------------------------------------------------------------- /vignettes/priorsense_with_jags.qmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Using priorsense with JAGS" 3 | vignette: > 4 | %\VignetteIndexEntry{Using priorsense with JAGS} 5 | %\VignetteEngine{quarto::html} 6 | %\VignetteEncoding{UTF-8} 7 | --- 8 | 9 | 10 | ```{r} 11 | #| include: false 12 | ggplot2::theme_set(bayesplot::theme_default(base_family = "sans")) 13 | 14 | options(priorsense.plot_help_text = FALSE) 15 | ``` 16 | 17 | 18 | ```{r} 19 | #| message: false 20 | #| warning: false 21 | library(R2jags) 22 | library(posterior) 23 | library(priorsense) 24 | ``` 25 | 26 | To use `priorsense` with a JAGS model, the log prior and log likelihood 27 | evaluations should be added to the model code. 28 | 29 | ```{r} 30 | model_string <- " 31 | model { 32 | for(n in 1:N) { 33 | y[n] ~ dnorm(mu, tau) 34 | log_lik[n] <- likelihood_alpha * logdensity.norm(y[n], mu, tau) 35 | } 36 | mu ~ dnorm(0, 1) 37 | sigma ~ dnorm(0, 1 / 2.5^2) T(0,) 38 | tau <- 1 / sigma^2 39 | lprior <- prior_alpha * logdensity.norm(mu, 0, 1) + logdensity.norm(sigma, 0, 1 / 2.5^2) 40 | } 41 | " 42 | ``` 43 | 44 | Using `R2jags::jags()` to fit the model. 45 | 46 | ```{r} 47 | #| message: false 48 | #| warning: false 49 | model_con <- textConnection(model_string) 50 | data <- example_powerscale_model()$data 51 | 52 | set.seed(123) 53 | 54 | # monitor parameters of interest along with log-likelihood and log-prior 55 | variables <- c("mu", "sigma", "log_lik", "lprior") 56 | 57 | jags_fit <- jags( 58 | data, 59 | model.file = model_con, 60 | parameters.to.save = variables, 61 | n.chains = 4, 62 | DIC = FALSE, 63 | quiet = TRUE, 64 | progress.bar = "none" 65 | ) 66 | ``` 67 | 68 | Then the `priorsense` functions will work as usual. 69 | 70 | ```{r} 71 | powerscale_sensitivity(jags_fit) 72 | ``` 73 | 74 | ```{r} 75 | #| message: false 76 | #| warning: false 77 | #| fig-width: 6 78 | #| fig-height: 4 79 | powerscale_plot_dens(jags_fit) 80 | ``` 81 | -------------------------------------------------------------------------------- /vignettes/quantity_of_interest.qmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Quantities of interest for sensitivity checks" 3 | vignette: > 4 | %\VignetteIndexEntry{Quantities of interest for sensitivity checks} 5 | %\VignetteEngine{quarto::html} 6 | %\VignetteEncoding{UTF-8} 7 | --- 8 | 9 | ## Choosing a quantity of interest 10 | 11 | There is no quantity to check the sensitivity of in all models. What 12 | you should look at depends on the model and what it is used for. Here 13 | we outline three options: measures of model fit, predictions, and 14 | parameters. 15 | 16 | ### Measures of model fit 17 | 18 | If you are evaluating the model based on some measure, it can be 19 | useful to assess how this measure of performance changes when changing 20 | the prior or likelihood. Examples of measures of model fit include 21 | log-score, R2, and metrics such as MAE or RMSE. 22 | 23 | ### Predictions 24 | 25 | If you are interested in the predictions your model makes for some 26 | specific quantity, then you can look at how those predictions would 27 | change depending on the prior/likelihood perturbations. 28 | 29 | ### Parameters 30 | 31 | If your model has parameters that are meaningful and interpretable, 32 | then you can look at those parameters specifically. In many cases 33 | there are far too many parameters, or they are not interpretable 34 | individually, and the other options are likely more applicable. 35 | -------------------------------------------------------------------------------- /vignettes/selecting_priors_and_quantities.qmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Selecting priors to power-scale and posterior quantities to check" 3 | vignette: > 4 | %\VignetteIndexEntry{Selecting priors to power-scale and posterior quantities to check} 5 | %\VignetteEngine{quarto::html} 6 | %\VignetteEncoding{UTF-8} 7 | --- 8 | 9 | ```{r} 10 | #| include: false 11 | ggplot2::theme_set(bayesplot::theme_default(base_family = "sans")) 12 | options(brms.backend = "rstan") 13 | ``` 14 | 15 | # Introduction 16 | 17 | Priorsense is a package for prior and likelihood sensitivity 18 | checks. It can be used to detect prior-data conflict and weak 19 | likelihood. 20 | 21 | This vignette demonstrates two different but related concepts: 22 | (1) selecting different priors to power-scale, and (2) specifying 23 | which posterior quantities to check the sensitivity of. 24 | 25 | We will fit two different models on the same data set. The first is a 26 | linear model, which has easily interpretable parameters. 27 | 28 | The second model includes splines and the spline coefficient 29 | parameters are not as easy to interpret. The specific model is not 30 | important, as the general principles apply for any model that has many 31 | parameters, correlated parameters or uninterpretable parameters. This 32 | includes other models with smooths, non-linear models, Gaussian 33 | processes and other more complex models. 34 | 35 | The features used here require `brms` version 2.22.11 or greater. 36 | 37 | The main takeaways for this vignette are: 38 | 39 | - prior tagging makes it possible to partition priors to make 40 | selective power-scaling easier 41 | 42 | - in more complex models, it is often better to check the sensitivity 43 | of predictions or predictive measures rather than the parameters 44 | 45 | ```{r} 46 | #| message: false 47 | #| warning: false 48 | library(brms) 49 | library(priorsense) 50 | library(posterior) 51 | 52 | options(priorsense.plot_help_text = FALSE) 53 | ``` 54 | 55 | We use the `airquality` data set, and fit a model predicting the 56 | amount of ozone based on the temperature. 57 | 58 | ```{r} 59 | data(airquality) 60 | aq <- na.omit(airquality) 61 | ``` 62 | 63 | # Linear model 64 | 65 | We first fit a linear model, with some priors specified. For each of 66 | the specified priors we add a `tag`, which will be used later to 67 | select which priors are power-scaled. 68 | 69 | ```{r} 70 | #| message: false 71 | #| warning: false 72 | #| results: hide 73 | fit_lin <- brm( 74 | formula = bf(Ozone ~ Temp), 75 | data = aq, 76 | family = gaussian(), 77 | prior = c( 78 | prior(normal(0, 5), class = "b", coef = "Temp", tag = "b"), 79 | prior(normal(0, 10), class = "sigma", tag = "sigma"), 80 | prior(normal(0, 100), class = "Intercept", tag = "intercept") 81 | ), 82 | seed = 123, 83 | refresh = 0, 84 | silent = 2 85 | ) 86 | ``` 87 | 88 | Rather than working with the `brmsfit` object directly, we will first 89 | extract the posterior draws. We will work with `draws` object using 90 | the `posterior` package so derived quantities can be added more 91 | easily. The `brmsfit` does not include the `log_lik` evaluations, 92 | so we will add those to the draws object using `posterior::bind_draws` 93 | 94 | ```{r} 95 | post_draws_lin <- as_draws_df(fit_lin) |> 96 | bind_draws(log_lik_draws(fit_lin)) 97 | ``` 98 | 99 | As the model is simple, with only one predictor, and each parameter is 100 | directly interpretable, we can perform the power-scaling sensitivity 101 | check directly on all the marginal posteriors of the parameters. 102 | 103 | ```{r} 104 | powerscale_sensitivity( 105 | post_draws_lin 106 | ) 107 | ``` 108 | 109 | This indicates that when we power-scale all the priors, the posterior 110 | of sigma is changing. 111 | 112 | Instead of looking at the parameter posteriors, we can check the 113 | sensitivity of predictions and predictive performance measures. 114 | 115 | For predictions, we will focus on the predictions at the minimum, 116 | median and maximum temperatures from the data. 117 | 118 | For predictive performance measures, we will use the in-sample 119 | Bayesian R2 and log-score. 120 | 121 | We first define a log-score function. 122 | 123 | ```{r} 124 | logscore <- function(x) { 125 | as.matrix(rowSums(log_lik(x))) 126 | } 127 | ``` 128 | 129 | And then bind the draws of the predictions and measures to the 130 | posterior draws using `posterior::bind_draws()`. For this we will use 131 | the `predictions_as_draws` helper function provided by `priorsense` 132 | which transforms predictions from `brms` to draws objects. 133 | 134 | ```{r} 135 | post_draws_lin <- post_draws_lin |> 136 | bind_draws( 137 | predictions_as_draws( 138 | x = fit_lin, 139 | predict_fn = bayes_R2, 140 | prediction_names = "R2", 141 | summary = FALSE 142 | ) 143 | ) |> 144 | bind_draws( 145 | predictions_as_draws( 146 | x = fit_lin, 147 | predict_fn = logscore, 148 | prediction_names = "logscore" 149 | ) 150 | ) |> 151 | bind_draws( 152 | predictions_as_draws( 153 | x = fit_lin, 154 | predict_fn = posterior_epred, 155 | prediction_names = c("pred_minTemp", "pred_medianTemp", 156 | "pred_maxTemp"), 157 | newdata = data.frame( 158 | Temp = c(min(aq$Temp), 159 | median(aq$Temp), 160 | max(aq$Temp))) 161 | ) 162 | ) 163 | 164 | powerscale_sensitivity( 165 | post_draws_lin 166 | ) 167 | ``` 168 | 169 | In this case, these predictive metrics do not appear to be sensitive 170 | to power-scaling the prior. If we are focused on prediction, we might 171 | not be concerned about the potential prior-data conflict for the sigma 172 | parameter. However, as the model is simple and sigma is interpretable 173 | we can continue investigation. 174 | 175 | We can confirm that it is the sigma prior that is causing the possible 176 | prior-data conflict, by using the `prior_selection` argument and 177 | specifying the `tag` we defined when creating the priors. 178 | 179 | ```{r} 180 | powerscale_sensitivity( 181 | post_draws_lin, 182 | prior_selection = c("sigma", "intercept") 183 | ) 184 | ``` 185 | 186 | And we can visualise the conflict. 187 | 188 | ```{r} 189 | #| message: false 190 | #| warning: false 191 | #| fig.width: 4 192 | #| fig.height: 4 193 | powerscale_plot_dens( 194 | post_draws_lin, 195 | variable = "sigma", 196 | prior_selection = "sigma" 197 | ) 198 | ``` 199 | 200 | Here we can see that there is a tendency for the posterior of sigma to 201 | shift closer to zero when the prior is strengthened (power-scaling 202 | alpha > 1). In this case, we did not have strong prior information 203 | that informed the prior, so we can consider a wider prior for sigma. 204 | 205 | 206 | # Spline model 207 | 208 | Next we extend our model by adding splines (and use a wider prior on 209 | sigma). This model is more complex, so it is more important to focus 210 | on checking the sensitivity of specific posterior quantities, rather 211 | than all the parameters. Here we will focus on the Bayesian R2, the 212 | log-score and the predictions at the minimum, median and maximum of 213 | the observed temperature. 214 | 215 | 216 | ```{r} 217 | #| message: false 218 | #| warning: false 219 | #| results: hide 220 | fit_spline <- brm( 221 | formula = bf(Ozone ~ s(Temp)), 222 | data = aq, 223 | family = gaussian(), 224 | prior = c( 225 | prior(normal(0, 5), class = "b", coef = "sTemp_1", tag = "b"), 226 | prior(normal(0, 10), class = "sds", coef = "s(Temp)", tag = "sds"), 227 | prior(normal(0, 30), class = "sigma", tag = "sigma"), 228 | prior(normal(0, 100), class = "Intercept", tag = "intercept") 229 | ), 230 | seed = 123, 231 | refresh = 0, 232 | silent = 2 233 | ) 234 | ``` 235 | 236 | ```{r} 237 | post_draws_spline <- as_draws_df(fit_spline) |> 238 | bind_draws(log_lik_draws(fit_spline)) |> 239 | bind_draws( 240 | predictions_as_draws( 241 | x = fit_spline, 242 | predict_fn = bayes_R2, 243 | prediction_names = "R2", summary = FALSE) 244 | ) |> 245 | bind_draws( 246 | predictions_as_draws( 247 | x = fit_spline, 248 | predict_fn = logscore, 249 | prediction_names = "logscore") 250 | ) |> 251 | bind_draws( 252 | predictions_as_draws( 253 | x = fit_spline, 254 | predict_fn = posterior_epred, 255 | prediction_names = c("pred_minTemp", "pred_medianTemp", "pred_maxTemp"), 256 | newdata = data.frame( 257 | Temp = c(min(aq$Temp), 258 | median(aq$Temp), 259 | max(aq$Temp)) 260 | ) 261 | ) 262 | ) 263 | ``` 264 | 265 | We start with power-scaling all priors, but only looking at the effect 266 | on `R2` and `logscore` and the predictions. 267 | 268 | ```{r} 269 | powerscale_sensitivity( 270 | post_draws_spline, 271 | variable = c("R2", "logscore", "pred_minTemp", 272 | "pred_medianTemp", "pred_maxTemp") 273 | ) 274 | ``` 275 | 276 | We see sensitivity in both measures. Next, we selectively power-scale 277 | different priors by specifying the corresponding `tag` in 278 | `prior_selection`. 279 | 280 | As this model introduced a prior on the `sds` term, we can start 281 | there. 282 | 283 | ```{r} 284 | powerscale_sensitivity( 285 | post_draws_spline, 286 | variable = c("R2", "logscore", "pred_minTemp", 287 | "pred_medianTemp", "pred_maxTemp"), 288 | prior_selection = "sds" 289 | ) 290 | ``` 291 | 292 | There is clear sensitivity to this prior. We can check all the other 293 | priors at once by providing a vector as the `prior_selection` 294 | argument. 295 | 296 | ```{r} 297 | powerscale_sensitivity( 298 | post_draws_spline, 299 | variable = c("R2", "logscore", "pred_minTemp", 300 | "pred_medianTemp", "pred_maxTemp"), 301 | prior_selection = c("intercept", "sigma", "b") 302 | ) 303 | ``` 304 | 305 | We can visualise the effect of power-scaling the `sds` prior on the 306 | posterior `R2`, `logscore` and the predictions. Here we visualise the 307 | change in posterior mean and standard deviation. 308 | 309 | ```{r} 310 | #| message: false 311 | #| warning: false 312 | #| fig.width: 6 313 | #| fig.height: 10 314 | powerscale_plot_quantities( 315 | post_draws_spline, 316 | div_measure = NULL, 317 | variable = c("R2", "logscore", "pred_minTemp", 318 | "pred_medianTemp", "pred_maxTemp"), 319 | prior_selection = "sds" 320 | ) 321 | ``` 322 | 323 | Although not extremely sensitive, there is a tendency for the 324 | in-sample predictive performance measures to decrease as the prior is 325 | strengthened. This is natural when strengthening the prior leads to 326 | less flexibility in the model. In this case larger `sds` implies more 327 | flexibility in the spline component of the model. If this is not what 328 | we are intending with the choice of prior on `sds`, we may want to 329 | rethink and change it. 330 | -------------------------------------------------------------------------------- /vignettes/sensitivity_diagnostic.qmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Interpreting sensitivity diagnostics" 3 | vignette: > 4 | %\VignetteIndexEntry{Interpreting sensitivity diagnostics} 5 | %\VignetteEngine{quarto::html} 6 | %\VignetteEncoding{UTF-8} 7 | --- 8 | 9 | Priorsense provides numerical diagnostics for sensitivity along with 10 | graphics. Here we describe the interpretation of the sensitivity 11 | diagnostics. 12 | 13 | # Diagnostic value 14 | 15 | The sensitivity diagnostic value given by `powerscale_sensitivity()` 16 | is based on a measure of how much the posterior would change if the 17 | prior or likelihood is changed. This value is provided for each 18 | marginal posterior specified in the `variable` argument. In simple 19 | models with few parameters, it is reasonable to look at sensitivity 20 | for all the parameters. But as model complexity increases, and there 21 | are more parameters or strong posterior dependencies, it is better to 22 | focus on sensitivity of specific parameters with meaningful 23 | interpretations or on derived quantities of interest. 24 | 25 | # Diagnostic messages 26 | 27 | Sensitivity diagnostic values are given for both prior and likelihood 28 | sensitivity. These values should be considered and interpreted 29 | together. Based on the values, a diagnosis is also given. Currently, 30 | this is either "strong prior / weak likelihood" (if the prior 31 | sensitivity is higher than a threshold and the likelihood sensitivity 32 | is lower than a threshold) or "prior-data conflict" (if both types of 33 | sensitivity are higher than the threshold). 34 | 35 | **These diagnostic messages do not necessarily indicate problems with the 36 | model.** They are informative messages that describe the 37 | interplay between the chosen prior and likelihood. If your prior is 38 | meant to be informative, influence on the posterior is desired and 39 | prior-data conflict may not be an issue. However, if you did not put 40 | much effort into choosing the priors, these messages can let you know 41 | if you should be more deliberate in your prior specification. 42 | 43 | ## Strong prior / weak likelihood 44 | 45 | This can occur when: 46 | 47 | - the prior is completely dominating the likelihood such that changing 48 | the likelihood strength has little to no impact on the posterior. The 49 | prior may be extremely informative and a using a weaker prior may 50 | remove this domination. 51 | 52 | - the likelihood is uninformative and no information is gained by 53 | increasing the strength of the likelihood. The prior will always have 54 | an effect in this case. 55 | 56 | ## Prior-data conflict 57 | 58 | This occurs when the posterior is sensitive to changes to both the 59 | prior and the likelihood. This indicates that the prior and likelihood 60 | are both influencing the posterior and may be in conflict with 61 | one-another. 62 | --------------------------------------------------------------------------------