as.expectation.logical() missing message in case of failure for testthat >=2.0

[zappingseb]

This might be related to issue #693

For testing our packages we are double checking the message from as.expectation.logical and printing it out by

rec <- 2
exp <- 2
expect_equal(
  rec,
  exp,
  message=glue("Expect equal: \"Received\":\"{rec}\", \"Expected\":\"{exp}\"")
)

and basically parse the information given in the message to show it to the users in a test report. We can create a table with the info:

data.frame(
   success  = "expectation_success" %in% class(expec),
   received = stringr::str_extract(expec$message,"(?<=Received\"\\:\")[^\\,]*(?=\\\")")
   expected = stringr::str_extract(expec$message,"(?<=Expected\"\\:\")[^\\,]*(?=\\\")")
)
>success  received expected
>   TRUE        2        2

This went great in testthat <2.0. Now the expect as.expectation.logical destroys the message in case of success.

as.expectation.logical <- function(x, message, ..., srcref = NULL, info = NULL) {
  type <- if (x) "success" else "failure"
  message <- if (x) "success" else add_info(message, info)
  expectation(type, message, srcref = srcref)
}

we just receive

>success  received expected
>   TRUE      ""       ""

Could you plugin an option into the API to always give the failure message? Or is there a way to put our message anywhere else, e.g. into srcref?

A proposal by the RTest team is to provide an option such as allMessages:

as.expectation.logical <- function(x, message, ..., srcref = NULL, info = NULL) {
  type <- if (x) "success" else "failure"
  message <- if (x && !getOption("allMessages", default = FALSE)) "success" else add_info(message, info)
  expectation(type, message, srcref = srcref)
}

[AlexSuleap]

+1

[hadley]

Can you provide a bit more information as to why you're doing this? Or provide a reprex? I don't quite understand the problem.

[zappingseb]

Dear @hadley

Thank you for taking this issue into the milestones.

The reason we are doing this is due to the regulated environment (Pharma) we are working in. Our tests get reviewed by non-coders. These people are experts in the field and can interpret numbers and tolerances, but not code. Additionally, tests need to be readable in >20 years in case regulatory authorities question the safety of a product. You can imagine that R packages or even R might have changed a lot in such a time frame. A test output like 5 is equal to 5.01 with tolerance 0.1 is still valid and readable, though.

Below you can find a reprex with the code we are using to extract this information. The reprex runs for testthat 1.0.2, testthat 2.0.1 and the proposed change of as.expecation.logical

dir.create(file.path(tempdir(), "templib_102"))
devtools::install_version(package = "testthat", version = "1.0.2", lib = file.path(tempdir(), "templib_102"), upgrade = "never")
#> Downloading package from url: https://cran.rstudio.com//src/contrib/Archive/testthat/testthat_1.0.2.tar.gz

dir.create(file.path(tempdir(), "templib_201"))
devtools::install_version(package = "testthat", version = "2.0.1", lib = file.path(tempdir(), "templib_201"), upgrade = "never")
#> Downloading package from url: https://cran.rstudio.com/src/contrib/testthat_2.0.1.tar.gz

# Function to extract information out of reporter result message
extract_test_info <- function(reporter_result = NULL) {
  stopifnot(methods::is(reporter_result, "expectation"))

  data.frame(
    success = "expectation_success" %in% class(reporter_result),
    received = stringr::str_extract(reporter_result$message, "(?<=Received\"\\:\")[^\\,]*(?=\\\")"),
    expected = stringr::str_extract(reporter_result$message, "(?<=Expected\"\\:\")[^\\,]*(?=\\\")"),
    tolerance = stringr::str_extract(reporter_result$message, "(?<=Tolerance\"\\:\")[^\\,]*(?=\\\")")
  )
}

# Define a test to run with a reporter
simple_test <- function(reporter) {
  exp <- 2
  rec <- 2.0001
  testthat::with_reporter(
    reporter,
    testthat::test_that("my example test", {
      tolerance <- 0.01
      testthat::expect_equal(
        exp,
        rec,
        tolerance = tolerance,
        # Assign information about the test
        info = glue::glue("Expect equal: \"Received\":\"{rec}\", \"Expected\":\"{exp}\", \"Tolerance\":\"{tolerance}\"")
      )
      tolerance <- 0.000001
      testthat::expect_equal(
        exp,
        rec,
        tolerance = tolerance,
        # Assign information about the test
        info = glue::glue("Expect equal: \"Received\":\"{rec}\", \"Expected\":\"{exp}\", \"Tolerance\":\"{tolerance}\"")
      )
    })
  )
  return(reporter)
}

old_libpaths <- .libPaths()

# Behaviour from testthat 1.0.X
.libPaths(c(file.path(tempdir(), "templib_102"), .libPaths()))

library(testthat)
stopifnot(packageVersion("testthat") == "1.0.2")
# Create a testthat Reporter
reporter <- testthat::ListReporter$new()

# Run two simple tests, one failing, one succesful
reporter <- simple_test(reporter)

# Output the result
#
lapply(reporter$results$as_list()[[1]]$results, extract_test_info)
#> [[1]]
#>   success received expected tolerance
#> 1    TRUE   2.0001        2      0.01
#> 
#> [[2]]
#>   success received expected tolerance
#> 1   FALSE   2.0001        2     1e-06


# Current behaviour (like testthat >= 2.0)
unloadNamespace("testthat")
.libPaths(old_libpaths)
.libPaths(c(file.path(tempdir(), "templib_201"), .libPaths()))

library(testthat)
stopifnot(packageVersion("testthat") == "2.0.1")
# Create a testthat Reporter
reporter <- testthat::ListReporter$new()

# Run two simple tests, one failing, one succesful
reporter <- simple_test(reporter)

# Output the result
#
# Succesful test removed all infos as Received, Expected, Tolerance.
# The result cannot be read by someone who did not write the test anymore.
lapply(reporter$results$as_list()[[1]]$results, extract_test_info)
#> [[1]]
#>   success received expected tolerance
#> 1    TRUE     <NA>     <NA>      <NA>
#> 
#> [[2]]
#>   success received expected tolerance
#> 1   FALSE   2.0001        2     1e-06

# Proposed behaviour (like testthat < 2.0) + global option
options("allMessages" = TRUE)

# New expectation logical as proposed in issue 836
as.expectation.logical <- function(x, message, ..., srcref = NULL, info = NULL) {
  type <- if (x) "success" else "failure"
  message <- if (x & !getOption("allMessages", default = FALSE)) {
    "success"
  } else {
    testthat:::add_info(message, info)
  }
  testthat::expectation(type, message, srcref = srcref)
}
# Assign a new as.expectation.logical to testthat namespace
tryCatch(

  assignInNamespace("as.expectation.logical", as.expectation.logical, ns = "testthat", pos = "package:testthat"),
  error = function(e) {
    if (grepl(pattern = "mode", e)) {
      message("success")
    } else {
      stop("overwriting namespace of testthat is not possible")
    }
  }
)
#> success
# Run two simple tests, one failing, one succesful
reporter <- testthat::ListReporter$new()
reporter <- simple_test(reporter)

# The ouput contains all the information for the succesful and
# failed test
lapply(reporter$results$as_list()[[1]]$results, extract_test_info)
#> [[1]]
#>   success received expected tolerance
#> 1    TRUE   2.0001        2      0.01
#> 
#> [[2]]
#>   success received expected tolerance
#> 1   FALSE   2.0001        2     1e-06

^{Created on 2019-04-02 by the reprex package (v0.2.1)}

Session info

devtools::session_info()
#> - Session info ----------------------------------------------------------
#>  setting  value                       
#>  version  R version 3.5.2 (2018-12-20)
#>  os       Windows 10 x64              
#>  system   x86_64, mingw32             
#>  ui       RTerm                       
#>  language (EN)                        
#>  collate  German_Germany.1252         
#>  ctype    German_Germany.1252         
#>  tz       Europe/London               
#>  date     2019-04-02                  
#> 
#> - Packages --------------------------------------------------------------
#>  package     * version date       lib source        
#>  assertthat    0.2.0   2017-04-11 [2] CRAN (R 3.5.2)
#>  backports     1.1.3   2018-12-14 [2] CRAN (R 3.5.2)
#>  callr         3.1.1   2018-12-21 [2] CRAN (R 3.5.2)
#>  cli           1.0.1   2018-09-25 [2] CRAN (R 3.5.2)
#>  crayon        1.3.4   2017-09-16 [2] CRAN (R 3.5.2)
#>  desc          1.2.0   2018-05-01 [2] CRAN (R 3.5.2)
#>  devtools      2.0.1   2018-10-26 [2] CRAN (R 3.5.2)
#>  digest        0.6.18  2018-10-10 [2] CRAN (R 3.5.2)
#>  evaluate      0.13    2019-02-12 [2] CRAN (R 3.5.2)
#>  fs            1.2.6   2018-08-23 [2] CRAN (R 3.5.2)
#>  glue          1.3.0   2018-07-17 [2] CRAN (R 3.5.2)
#>  highr         0.7     2018-06-09 [2] CRAN (R 3.5.2)
#>  htmltools     0.3.6   2017-04-28 [2] CRAN (R 3.5.2)
#>  knitr         1.21    2018-12-10 [2] CRAN (R 3.5.2)
#>  magrittr      1.5     2014-11-22 [2] CRAN (R 3.5.2)
#>  memoise       1.1.0   2017-04-21 [2] CRAN (R 3.5.2)
#>  pkgbuild      1.0.2   2018-10-16 [2] CRAN (R 3.5.2)
#>  pkgload       1.0.2   2018-10-29 [2] CRAN (R 3.5.2)
#>  prettyunits   1.0.2   2015-07-13 [2] CRAN (R 3.5.2)
#>  processx      3.2.1   2018-12-05 [2] CRAN (R 3.5.2)
#>  ps            1.3.0   2018-12-21 [2] CRAN (R 3.5.2)
#>  R6            2.3.0   2018-10-04 [2] CRAN (R 3.5.2)
#>  Rcpp          1.0.1   2019-03-17 [2] CRAN (R 3.5.3)
#>  remotes       2.0.2   2018-10-30 [2] CRAN (R 3.5.2)
#>  rlang         0.3.1   2019-01-08 [2] CRAN (R 3.5.2)
#>  rmarkdown     1.11    2018-12-08 [2] CRAN (R 3.5.2)
#>  rprojroot     1.3-2   2018-01-03 [2] CRAN (R 3.5.2)
#>  sessioninfo   1.1.1   2018-11-05 [2] CRAN (R 3.5.2)
#>  stringi       1.2.4   2018-07-20 [2] CRAN (R 3.5.2)
#>  stringr       1.4.0   2019-02-10 [2] CRAN (R 3.5.2)
#>  testthat    * 2.0.1   2018-10-13 [1] CRAN (R 3.5.2)
#>  usethis       1.4.0   2018-08-14 [2] CRAN (R 3.5.2)
#>  withr         2.1.2   2018-03-15 [2] CRAN (R 3.5.2)
#>  xfun          0.4     2018-10-23 [2] CRAN (R 3.5.2)
#>  yaml          2.2.0   2018-07-25 [2] CRAN (R 3.5.2)
#> 
#> [1] C:/Users/wolfs25/AppData/Local/Temp/Rtmp2XWobK/templib_201
#> [2] C:/RVersions/R-3.5.2/library