From e072337f53237d88a6137e5d3ec5cdafac275035 Mon Sep 17 00:00:00 2001
From: fredjaya <fredjaya1@gmail.com>
Date: Mon, 11 Dec 2023 14:01:19 +1100
Subject: [PATCH] Func to test relative diff between two matrices.

---
 CHANGELOG.md                             |  6 +++---
 R/test-util.R                            | 16 ++++++++++++++++
 tests/testthat/test-design_effect.R      |  4 ++++
 tests/testthat/test-fisher_information.R | 18 +++++++++---------
 4 files changed, 32 insertions(+), 12 deletions(-)
 create mode 100644 R/test-util.R

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 4385060..64f711b 100644
--- a/CHANGELOG.md
+++ b/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]:
diff --git a/R/test-util.R b/R/test-util.R
new file mode 100644
index 0000000..947c6d2
--- /dev/null
+++ b/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)
+    }
+  }
+}
diff --git a/tests/testthat/test-design_effect.R b/tests/testthat/test-design_effect.R
index 4304769..a7d89cf 100644
--- a/tests/testthat/test-design_effect.R
+++ b/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() ----------------------------------------------------
+
diff --git a/tests/testthat/test-fisher_information.R b/tests/testthat/test-fisher_information.R
index b1fade6..41b1b5c 100644
--- a/tests/testthat/test-fisher_information.R
+++ b/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 --------------------------------------------------------