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)
}
)