Func to test relative diff between two matrices.

CHANGELOG.md

@@ -33,9 +33,6 @@ and this project adheres to
 - Implement warnings for input checks (#3, #27)
 - Include tests with expected inputs (#27, #34)  
 
-### [v0.1.1] - 2023-12-08
-- Add check_rho() to input_check() (#32)  
-
 ## [Available]  
 
 ### [v0.1.1] - 2023-12-07  
@@ -47,6 +44,7 @@ and this project adheres to
 - Documentation for `_random()` functions and `pooling_strategies.R` (#31)
 - Tests (#29, #30)
 - Multiple local function definitions for `integrand` (#21)
+- check_rho() added to input_check() (#32)
 
 ### [v0.1.0] - 2023-12-05  
 
@@ -90,5 +88,7 @@ also had extreme parameters.
 - GitHub Action workflows `check-standard` and `test-coverage` implemented (#5)  
 
 [upcoming]:
+[0.1.1]:
+[0.1.0]:
 [0.0.2]:
 [0.0.1]:

R/test-util.R

@@ -0,0 +1,16 @@
+relative_difference <- function(actual, expected, tolerance) {
+  # https://github.com/AngusMcLure/PoolPoweR/issues/27
+  # Always uses relative tolerance when testing for equality
+  # all.equal() switches to absolute tolerance when values are small
+  cm <- matrix(c(1,1,1,1), nrow = 2)
+  comp <- all.equal(actual/expected, cm)
+  if(class(comp) == "logical") return(TRUE) # All values are perfectly equal
+  else {
+    mean_rel_diff <- as.numeric(strsplit(comp, " ")[[1]][4])
+    if(mean_rel_diff < tolerance) return(TRUE)
+    else {
+      warning(glue::glue("mean_rel_diff: {mean_rel_diff} is >= tolerance: {tolerance}"))
+      return(FALSE)
+    }
+  }
+}

tests/testthat/test-design_effect.R

@@ -1,3 +1,4 @@
+### design_effect() -----------------------------------------------------------
 test_that("design_effect() gives consistent output for basic tests", {
   # This one has reasonable inputs
   expect_equal(
@@ -60,3 +61,6 @@ test_that("bad inputs caught in design_effect()", {
   expect_error(design_effect(pool_size = 5, pool_number = 10, prevalence = 0.01, correlation = 0.1, sensitivity = 1, specificity = 1, form = "binomal"),
                "form must be one of 'beta', 'logitnorm', 'cloglognorm', or 'discrete'.")
 })
+
+### design_effect_random() ----------------------------------------------------
+

tests/testthat/test-fisher_information.R

@@ -1,4 +1,3 @@
-# Tolerance to address floating point precision errors
 test_that("fi_pool() works with expected input ranges", {
   # Tests mainly to ensure same outputs when refactoring fi_pool internals
   # This one has reasonable params
@@ -36,16 +35,17 @@ test_that("fi_pool() works with expected input ranges", {
 })
 
 test_that("fi_pool_cluster() outputs a 2x2 matrix for input vectors of length 2", {
-  expect_true(all.equal(fi_pool_cluster(
+  act <- fi_pool_cluster(
     pool_size = 10, pool_number = 5, prevalence = 0.01, correlation = 0.05,
-    sensitivity = 0.95, specificity = 0.99),
-    matrix(c(1880.3484, -125.47514, -125.4751, 23.71574), nrow = 2), tolerance = 1e-5
-    ))
-  expect_true(all.equal(fi_pool_cluster(
+    sensitivity = 0.95, specificity = 0.99)
+  exp <- matrix(c(1880.3484, -125.47514, -125.4751, 23.71574), nrow = 2)
+  expect_true(relative_difference(act, exp, tolerance = 1e-7))
+
+  act <- fi_pool_cluster(
     pool_size = c(1, 2), pool_number = c(5, 10), prevalence = 0.01, correlation = 0.05,
-    sensitivity = 0.95, specificity = 0.99),
-    matrix(c(926.41807, -23.055960, -23.055960, 9.535592), nrow = 2), tolerance = 1e-6
-    ))
+    sensitivity = 0.95, specificity = 0.99)
+  exp <- matrix(c(926.41807, -23.055960, -23.055960, 9.535592), nrow = 2)
+  expect_true(relative_difference(act, exp, tolerance = 1e-7))
 })
 
 # Input argument checks --------------------------------------------------------