Improve test coverage and automate reporting (#40)

* Cover target distribution with value_and_gradient_log_density entry in tests * Test adapter state access * Add tests with progress bar disabled * Add test for error on invalid initial state * Add test coverage workflow * Add codecov badge * Update coverage job name for consistency
UCL · Oct 21, 2024 · 697bc44 · 697bc44
1 parent 330c39b
commit 697bc44
Show file tree

Hide file tree

Showing 7 changed files with 197 additions and 78 deletions.
diff --git a/.github/workflows/test-coverage.yaml 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
@@ -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)
 <!-- badges: end -->
 
 `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
@@ -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)
 <!-- badges: end -->
 
 `rmcmc` is an R package for simulating Markov chains using the Barker

diff --git 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
@@ -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
@@ -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
@@ -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"
+  )
+})