testthat ex 2: the square root function

Here’s a function to calculate square roots, using the ancient Babylonian method.

square_root <- function(x, tol = 1e-6)
{
  S <- x
  x <- log2(x) ^ 2
  repeat{
    x <- 0.5 * (x + (S / x))
    err <- x ^ 2 - S  
    if(abs(err) < tol)
    {
      break
    }
  }
  x
}

Test the function against some positive numbers, using base::sqrt to compute the expected value (since we know it gives the correct answer).

# +ve number tests
test_that(
  "square_root, with input 1024, returns 32",
  {
    expected <- 32
    actual <- square_root(1024)
    expect_equal(actual, expected)
  }
)
test_that(
  "square_root, with input 30.25, returns 5.5",
  {
    expected <- 5.5
    actual <- square_root(30.25)
    expect_equal(actual, expected)
  }
)

In case you tried a very large number (well done!), you might have discovered that the algorithm is really inefficient in this case. (You can test for long running code using takes_less_than, but that’s beyond the scope of this question.)

Test the function against a negative number.

test_that(
  "square_root, with a negative input, returns NaN",
  {
    expected <- NaN
    actual <- square_root(-1)
    expect_equal(actual, expected)
  }
)
## Error: Test failed: 'square_root, with a negative input, returns NaN'
## Not expected: missing value where TRUE/FALSE needed
## 1: withCallingHandlers(eval(code, new_test_environment), error = capture_calls, 
##        message = function(c) invokeRestart("muffleMessage"), warning = function(c) invokeRestart("muffleWarning"))
## 2: eval(code, new_test_environment)
## 3: eval(expr, envir, enclos)
## 4: square_root(-1) at <text>:5.

Does it work? If not, what goes wrong?

In this case, log2(-1) returns NaN, which feeds through to err being NaN, which then cause an error when it is used in the if condition.

Update the function to gracefully return NaN for negative inputs, then rerun your test.

# modify this function
library(assertive)
## assertive has some important changes.  Read ?changes for details.
## 
## Attaching package: 'assertive'
## 
## The following objects are masked from 'package:testthat':
## 
##     has_names, is_false, is_null, is_true
square_root2 <- function(x, tol = 1e-6)
{
  if(is_negative(x))
  {
    warning("Negative inputs are not supported; returning NaN.")
    return(NaN)
  }
  S <- x
  x <- log2(x) ^ 2
  repeat{
    x <- 0.5 * (x + (S / x))
    err <- x ^ 2 - S  
    if(abs(err) < tol)
    {
      break
    }
  }
  x
}

# -ve number tests
test_that(
  "square_root2, with a negative input, returns NaN",
  {
    expected <- NaN
    actual <- square_root2(-1)
    expect_equal(actual, expected)
  }
)

Test the function for zero length inputs: try both numeric() and NULL as inputs.

# zero-length tests
test_that(
  "square_root2, with a zero-length numeric input, returns a zero-length numeric",
  {
    expected <- numeric()
    actual <- square_root2(numeric())
    expect_equal(actual, expected)
  }
)
## Error: Test failed: 'square_root2, with a zero-length numeric input, returns a zero-length numeric'
## Not expected: argument is of length zero
## 1: withCallingHandlers(eval(code, new_test_environment), error = capture_calls, 
##        message = function(c) invokeRestart("muffleMessage"), warning = function(c) invokeRestart("muffleWarning"))
## 2: eval(code, new_test_environment)
## 3: eval(expr, envir, enclos)
## 4: square_root2(numeric()) at <text>:6.
test_that(
  "square_root2, with a null input, returns a zero-length numeric",
  {
    expected <- numeric()
    actual <- square_root2(NULL)
    expect_equal(actual, expected)
  }
)
## Error: Test failed: 'square_root2, with a null input, returns a zero-length numeric'
## Not expected: argument is of length zero
## 1: withCallingHandlers(eval(code, new_test_environment), error = capture_calls, 
##        message = function(c) invokeRestart("muffleMessage"), warning = function(c) invokeRestart("muffleWarning"))
## 2: eval(code, new_test_environment)
## 3: eval(expr, envir, enclos)
## 4: square_root2(NULL) at <text>:14.

Does they work? If not, what goes wrong?

Both these tests fall over at the if condition again. This requires a scalar input.

Add an assertion to check for zero-length inputs, then rerun your test.

# modify this function
square_root3 <- function(x, tol = 1e-6)
{
  if(is_empty(x))
  {
    return(numeric())
  }
  if(is_negative(x))
  {
    warning("Negative inputs are not supported; returning NaN.")
    return(NaN)
  }
  S <- x
  x <- log2(x) ^ 2
  repeat{
    x <- 0.5 * (x + (S / x))
    err <- x ^ 2 - S  
    if(abs(err) < tol)
    {
      break
    }
  }
  x
}

# zero length input tests
test_that(
  "square_root3, with a zero-length numeric input, returns a zero-length numeric",
  {
    expected <- numeric()
    actual <- square_root3(numeric())
    expect_equal(actual, expected)
  }
)
test_that(
  "square_root3, with a null input, returns a zero-length numeric",
  {
    expected <- numeric()
    actual <- square_root3(NULL)
    expect_equal(actual, expected)
  }
)

Test the function for vectorised inputs.

test_that(
  "square_root3, with a vector input, returns square roots of each element",
  {
    expected <- c(2, 5)
    actual <- square_root3(c(4, 25))
    expect_equal(actual, expected)
  }
)
## Error: Test failed: 'square_root3, with a vector input, returns square roots of each element'
## Not expected: actual not equal to expected
## 2/2 mismatches (average diff: 0.00261).
## First 2:
##  pos x    y      diff
##    1 2 2.00 -9.29e-08
##    2 5 5.01 -5.23e-03.

Does it work? If not, what goes wrong?

It’s that if condition again. (Pro-tip: If you want a vectorized function, try to use ifelse in place of if.)

Add an assertion to check for vectorized inputs, and rerun your test.

# modify this function
square_root4 <- function(x, tol = 1e-6)
{
  if(is_empty(x))
  {
    return(numeric())
  }
  if(length(x) > 1)
  {
    return(vapply(x, square_root, numeric(1)))
  }
  if(is_negative(x))
  {
    warning("Negative inputs are not supported; returning NaN.")
    return(NaN)
  }
  S <- x
  x <- log2(x) ^ 2
  repeat{
    x <- 0.5 * (x + (S / x))
    err <- x ^ 2 - S  
    if(abs(err) < tol)
    {
      break
    }
  }
  x
}

# vectorized input tests
test_that(
  "square_root34, with a vector input, returns square roots of each element",
  {
    expected <- c(2, 5)
    actual <- square_root4(c(4, 25))
    expect_equal(actual, expected)
  }
)