diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..fefc52e --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,61 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage + +permissions: read-all + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr, any::xml2 + needs: coverage + + - name: Test coverage + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v4 + with: + fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} + file: ./cobertura.xml + plugin: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v4 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/README.Rmd b/README.Rmd index 111148b..e3ee7c6 100644 --- a/README.Rmd +++ b/README.Rmd @@ -20,6 +20,7 @@ knitr::opts_chunk$set( [![pkgdown](https://github.com/UCL/rmcmc/actions/workflows/pkgdown.yaml/badge.svg)](https://github.com/UCL/rmcmc/actions/workflows/pkgdown.yaml) [![lint](https://github.com/UCL/rmcmc/actions/workflows/lint.yaml/badge.svg)](https://github.com/UCL/rmcmc/actions/workflows/lint.yaml) [![pre-commit](https://github.com/UCL/rmcmc/actions/workflows/pre-commit.yaml/badge.svg)](https://github.com/UCL/rmcmc/actions/workflows/pre-commit.yaml) +[![codecov](https://codecov.io/github/UCL/rmcmc/graph/badge.svg?token=PL8557fpgT)](https://codecov.io/github/UCL/rmcmc) `rmcmc` is an R package for simulating Markov chains using the Barker proposal to compute _Markov chain Monte Carlo_ (MCMC) estimates of expectations with respect to a target distribution on a real-valued vector space. diff --git a/README.md b/README.md index 7351531..5b675d3 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,7 @@ [![pkgdown](https://github.com/UCL/rmcmc/actions/workflows/pkgdown.yaml/badge.svg)](https://github.com/UCL/rmcmc/actions/workflows/pkgdown.yaml) [![lint](https://github.com/UCL/rmcmc/actions/workflows/lint.yaml/badge.svg)](https://github.com/UCL/rmcmc/actions/workflows/lint.yaml) [![pre-commit](https://github.com/UCL/rmcmc/actions/workflows/pre-commit.yaml/badge.svg)](https://github.com/UCL/rmcmc/actions/workflows/pre-commit.yaml) +[![codecov](https://codecov.io/github/UCL/rmcmc/graph/badge.svg?token=PL8557fpgT)](https://codecov.io/github/UCL/rmcmc) `rmcmc` is an R package for simulating Markov chains using the Barker diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R index 3538fcb..80d058d 100644 --- a/tests/testthat/helpers.R +++ b/tests/testthat/helpers.R @@ -1,8 +1,16 @@ -standard_normal_target_distribution <- function() { - list( +standard_normal_target_distribution <- function(value_and_gradient = FALSE) { + target_distribution <- list( log_density = function(x) -sum(x^2) / 2, gradient_log_density = function(x) -x ) + if (value_and_gradient) { + target_distribution[["value_and_gradient_log_density"]] <- function(x) { + list( + value = -sum(x^2) / 2, gradient = -x + ) + } + } + target_distribution } default_seed <- function() 9821415L diff --git a/tests/testthat/test-adaptation.R b/tests/testthat/test-adaptation.R index 755cc3e..d37cd60 100644 --- a/tests/testthat/test-adaptation.R +++ b/tests/testthat/test-adaptation.R @@ -47,6 +47,9 @@ for (target_accept_prob in c(0.2, 0.4, 0.6)) { ) check_adapter(adapter) adapter$initialize(initial_state = NULL) + adapter_state <- adapter$state() + expect_named(adapter_state, "log_scale") + expect_length(adapter_state$log_scale, 1) old_scale <- initial_scale # If accept probability higher than target scale should be increased for (s in 1:2) { @@ -104,6 +107,14 @@ for (dimension in c(1L, 2L, 5L)) { position <- rnorm(dimension) * target_scales state <- chain_state(position = position) adapter$initialize(state) + adapter_state <- adapter$state() + expect_named( + adapter_state, + c("mean_estimate", "variance_estimate"), + ignore.order = TRUE + ) + expect_length(adapter_state$mean_estimate, dimension) + expect_length(adapter_state$variance_estimate, dimension) # Proposal shape parameter should be adapted to close to target scales # over long run for (s in 1:3000) { @@ -154,6 +165,10 @@ for (dimension in c(1L, 2L, 3L)) { check_adapter(adapter) state <- chain_state(position = rnorm(dimension)) adapter$initialize(state) + adapter_state <- adapter$state() + expect_named(adapter_state, "shape") + expect_nrow(adapter_state$shape, dimension) + expect_ncol(adapter_state$shape, dimension) mean_accept_prob <- 0. for (sample_index in 1:10000) { state_and_statistics <- sample_metropolis_hastings( diff --git a/tests/testthat/test-chain_state.R b/tests/testthat/test-chain_state.R index aec72c2..cb73994 100644 --- a/tests/testthat/test-chain_state.R +++ b/tests/testthat/test-chain_state.R @@ -18,25 +18,33 @@ for (dimension in c(1L, 2L)) { expect_identical(state$momentum(), momentum) expect_identical(state$dimension(), dimension) }) - test_that( - sprintf( - "Evaluating log density (gradient) with chain state in dimension %i works", - dimension - ), - { - withr::with_seed(default_seed(), position <- rnorm(dimension)) - state <- chain_state(position) - target_distribution <- standard_normal_target_distribution() - expect_identical( - state$log_density(target_distribution), - target_distribution$log_density(position) - ) - expect_identical( - state$gradient_log_density(target_distribution), - target_distribution$gradient_log_density(position) - ) - } - ) + for (use_value_and_gradient in c(TRUE, FALSE)) { + test_that( + sprintf( + paste0( + "Evaluating log density (gradient) with chain state and ", + "use_value_and_gradient = %i in dimension %i works" + ), + use_value_and_gradient, + dimension + ), + { + withr::with_seed(default_seed(), position <- rnorm(dimension)) + target_distribution <- standard_normal_target_distribution( + use_value_and_gradient + ) + state <- chain_state(position) + expect_identical( + state$log_density(target_distribution), + target_distribution$log_density(position) + ) + expect_identical( + state$gradient_log_density(target_distribution), + target_distribution$gradient_log_density(position) + ) + } + ) + } test_that(sprintf("Copying chain state in dimension %i works", dimension), { withr::with_seed(default_seed(), { position <- rnorm(dimension) diff --git a/tests/testthat/test-chains.R b/tests/testthat/test-chains.R index 28cd12f..1e1cebc 100644 --- a/tests/testthat/test-chains.R +++ b/tests/testthat/test-chains.R @@ -2,69 +2,94 @@ for (n_warm_up_iteration in c(0, 1, 10)) { for (n_main_iteration in c(0, 1, 10)) { for (dimension in c(1, 2)) { for (trace_warm_up in c(TRUE, FALSE)) { - for (wrapped_initial_state in c(TRUE, FALSE)) { - test_that( - sprintf( - paste0( - "Sampling chain with %i warm-up iterations, %i main iterations", - " dimension %i, wrapped_initial_state = %i ", - "and trace_warm_up = %i works" + for (show_progress_bar in c(TRUE, FALSE)) { + for (wrapped_initial_state in c(TRUE, FALSE)) { + test_that( + sprintf( + paste0( + "Sampling chain with %i warm-up iterations, ", + "%i main iterations, dimension %i, ", + "trace_warm_up = %i, show_progress_bar = %i ", + "and wrapped_initial_state = %i works" + ), + n_warm_up_iteration, + n_main_iteration, + dimension, + trace_warm_up, + show_progress_bar, + wrapped_initial_state ), - n_warm_up_iteration, - n_main_iteration, - dimension, - wrapped_initial_state, - trace_warm_up - ), - { - target_distribution <- standard_normal_target_distribution() - barker_proposal(target_distribution) - proposal <- barker_proposal(target_distribution) - adapters <- list( - scale_adapter(proposal, initial_scale = 1.) - ) - withr::with_seed(default_seed(), { - position <- rnorm(dimension) - }) - if (wrapped_initial_state) { - initial_state <- chain_state(position) - } else { - initial_state <- position - } - results <- sample_chain( - target_distribution = target_distribution, - proposal = proposal, - initial_state = initial_state, - n_warm_up_iteration = n_warm_up_iteration, - n_main_iteration = n_main_iteration, - adapters = adapters, - trace_warm_up = trace_warm_up - ) - expected_results_names <- c("final_state", "traces", "statistics") - if (trace_warm_up) { + { + target_distribution <- standard_normal_target_distribution() + barker_proposal(target_distribution) + proposal <- barker_proposal(target_distribution) + adapters <- list( + scale_adapter(proposal, initial_scale = 1.) + ) + withr::with_seed(default_seed(), { + position <- rnorm(dimension) + }) + if (wrapped_initial_state) { + initial_state <- chain_state(position) + } else { + initial_state <- position + } + results <- sample_chain( + target_distribution = target_distribution, + proposal = proposal, + initial_state = initial_state, + n_warm_up_iteration = n_warm_up_iteration, + n_main_iteration = n_main_iteration, + adapters = adapters, + trace_warm_up = trace_warm_up, + show_progress_bar = show_progress_bar + ) expected_results_names <- c( - expected_results_names, "warm_up_traces", "warm_up_statistics" + "final_state", "traces", "statistics" ) + if (trace_warm_up) { + expected_results_names <- c( + expected_results_names, + "warm_up_traces", + "warm_up_statistics" + ) + } + expect_named( + results, + expected_results_names, + ignore.order = TRUE, + ) + expect_nrow(results$traces, n_main_iteration) + expect_ncol(results$traces, dimension + 1) + expect_nrow(results$statistics, n_main_iteration) + expect_ncol(results$statistics, 1) + if (trace_warm_up) { + expect_nrow(results$warm_up_traces, n_warm_up_iteration) + expect_ncol(results$warm_up_traces, dimension + 1) + expect_nrow(results$warm_up_statistics, n_warm_up_iteration) + expect_ncol(results$warm_up_statistics, 2) + } } - expect_named( - results, - expected_results_names, - ignore.order = TRUE, - ) - expect_nrow(results$traces, n_main_iteration) - expect_ncol(results$traces, dimension + 1) - expect_nrow(results$statistics, n_main_iteration) - expect_ncol(results$statistics, 1) - if (trace_warm_up) { - expect_nrow(results$warm_up_traces, n_warm_up_iteration) - expect_ncol(results$warm_up_traces, dimension + 1) - expect_nrow(results$warm_up_statistics, n_warm_up_iteration) - expect_ncol(results$warm_up_statistics, 2) - } - } - ) + ) + } } } } } } + +test_that("Sample chains with invalid initial_state raises error", { + target_distribution <- standard_normal_target_distribution() + barker_proposal(target_distribution) + proposal <- barker_proposal(target_distribution) + expect_error( + sample_chain( + target_distribution = target_distribution, + proposal = proposal, + initial_state = list(), + n_warm_up_iteration = 1, + n_main_iteration = 1, + ), + "initial_state" + ) +})