Func for rel diff between two numerics.

Update fisher_information.R tests to use new rel diff functions

R/test-util.R

@@ -1,10 +1,20 @@
-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
+# To address issue [#27](https://github.com/AngusMcLure/PoolPoweR/issues/27).
+# Ensures that relative tolerance is used between small values when testing for
+# equality.
+numeric_rel_diff <- function(act, exp, tolerance) {
+  rd <- abs(act-exp)/abs(exp)
+  if(rd < tolerance) TRUE
+  else {
+    warning(glue::glue("Relative difference: {rd} is >= tolerance: {tolerance}"))
+    FALSE
+  }
+}
+
+matrix_rel_diff <- function(act, exp, tolerance) {
   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
+  comp <- all.equal(act/exp, cm)
+  #comp <- mean(abs(act-exp)/mean(exp))
+  if(is.logical(comp)) return(TRUE) # All values are perfectly equal
   else {
     mean_rel_diff <- as.numeric(strsplit(comp, " ")[[1]][4])
     if(mean_rel_diff < tolerance) return(TRUE)

tests/testthat/test-fisher_information.R

@@ -1,51 +1,35 @@
 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
-  expect_equal(fi_pool(
-    pool_size = 10, prevalence = 0.01, sensitivity = 0.95, specificity = 0.99),
-    820.1759, tolerance = 1e-4
-  )
+  act <- fi_pool(pool_size = 10, prevalence = 0.01, sensitivity = 0.95, specificity = 0.99)
+  expect_true(numeric_rel_diff(act, 820.175856686646, tolerance = 1e-15))
+
   # These ones do not really
-  expect_equal(
-    fi_pool(
-      pool_size = 10,
-      prevalence = 0.7,
-      sensitivity = 0.8,
-      specificity = 0.9
-    ),
-    1.186457e-07,
-    tolerance = 1e-6
-  )
-  expect_equal(
-    fi_pool(
-      pool_size = 20,
-      prevalence = 0.55,
-      sensitivity = 0.9,
-      specificity = 0.6
-    ),
-    7.376202e-11,
-    tolerance = 1e-6
-  )
-  expect_true(is.nan(fi_pool(
-    pool_size = 10,
-    prevalence = 1,
-    sensitivity = 1,
-    specificity = 1
-  )))
+  act <- fi_pool(pool_size = 10, prevalence = 0.7, sensitivity = 0.8, specificity = 0.9)
+  expect_true(numeric_rel_diff(act, 1.18645717782e-07, tolerance = 1e-6)) # previously 1e-7
+
+  act <- fi_pool(pool_size = 20, prevalence = 0.55, sensitivity = 0.9, specificity = 0.6)
+  expect_true(numeric_rel_diff(act, 7.37620180817331e-11, tolerance = 1e-15))
+})
+
+test_that("fi_pool() returns NaN", {
+ expect_true(
+    is.nan(
+      fi_pool(pool_size = 10, prevalence = 1, sensitivity = 1, specificity = 1))
+    )
 })
 
 test_that("fi_pool_cluster() outputs a 2x2 matrix for input vectors of length 2", {
   act <- fi_pool_cluster(
     pool_size = 10, pool_number = 5, prevalence = 0.01, correlation = 0.05,
     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))
+  expect_true(matrix_rel_diff(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)
   exp <- matrix(c(926.41807, -23.055960, -23.055960, 9.535592), nrow = 2)
-  expect_true(relative_difference(act, exp, tolerance = 1e-7))
+  expect_true(matrix_rel_diff(act, exp, tolerance = 1e-7))
 })
 
 # Input argument checks --------------------------------------------------------