options for strict tests; few enhancements

DESCRIPTION

@@ -44,18 +44,19 @@ Suggests:
     png,
     rtables (>= 0.5.1),
     testthat (>= 3.1.5),
-    tinytex
+    tinytex,
+    withr (>= 2.0.0)
 VignetteBuilder:
     knitr
 RdMacros:
     lifecycle
-Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate,
+Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate, davidgohel/flextable,
     rstudio/htmltools, yihui/knitr, r-lib/lifecycle, r-lib/R6,
     rstudio/rmarkdown, rstudio/shiny, dreamRs/shinybusy,
     dreamRs/shinyWidgets, yaml=vubiostat/r-yaml, r-lib/zip,
-    davidgohel/flextable, rstudio/DT, yihui/formatR, tidyverse/ggplot2,
+    rstudio/DT, yihui/formatR, tidyverse/ggplot2,
     deepayan/lattice, cran/png, insightsengineering/rtables,
-    r-lib/testthat, rstudio/tinytex
+    r-lib/testthat, rstudio/tinytex, r-lib/withr
 Config/Needs/website: insightsengineering/nesttemplate
 Encoding: UTF-8
 Language: en-US

R/Previewer.R

@@ -82,7 +82,7 @@ reporter_previewer_srv <- function(id,
     function(input, output, session) {
       ns <- session$ns
 
-      teal.reporter::reset_report_button_srv("resetButtonPreviewer", reporter)
+      reset_report_button_srv("resetButtonPreviewer", reporter)
 
       output$encoding <- shiny::renderUI({
         reporter$get_reactive_add_card()
@@ -106,7 +106,7 @@ reporter_previewer_srv <- function(id,
             ),
             class = if (length(reporter$get_cards())) "" else "disabled"
           ),
-          teal.reporter::reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
+          reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
         )
       })
 

R/SimpleReporter.R

@@ -22,8 +22,9 @@
 #' @return `NULL`.
 #'
 #' @examples
-#' library(shiny)
 #' if (interactive()) {
+#'   library(shiny)
+#'
 #'   shinyApp(
 #'     ui = fluidPage(simple_reporter_ui("simple")),
 #'     server = function(input, output, session) {

R/yaml_utils.R

@@ -53,7 +53,6 @@ md_header <- function(x) {
 #' @return `input` argument or the appropriate `logical` value.
 #' @keywords internal
 #' @examples
-#'
 #' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter")
 #' conv_str_logi("TRUE")
 #' conv_str_logi("True")

tests/testthat/setup-options.R

@@ -0,0 +1,20 @@
+# `opts_partial_match_old` is left for exclusions due to partial matching in dependent packages (i.e. not fixable here)
+# it might happen that it is not used right now, but it is left for possible future use
+# use with: `withr::with_options(opts_partial_match_old, { ... })` inside the test
+opts_partial_match_old <- list(
+  warnPartialMatchDollar = getOption("warnPartialMatchDollar"),
+  warnPartialMatchArgs = getOption("warnPartialMatchArgs"),
+  warnPartialMatchAttr = getOption("warnPartialMatchAttr")
+)
+opts_partial_match_new <- list(
+  warnPartialMatchDollar = TRUE,
+  warnPartialMatchArgs = TRUE,
+  warnPartialMatchAttr = TRUE
+)
+
+if (isFALSE(getFromNamespace("on_cran", "testthat")()) && requireNamespace("withr", quietly = TRUE)) {
+  withr::local_options(
+    opts_partial_match_new,
+    .local_envir = testthat::teardown_env()
+  )
+}

tests/testthat/test-Archiver.R

@@ -13,8 +13,14 @@ card2$append_text("Header 2 text", "header2")
 card2$append_text("A paragraph of default text", "header2")
 lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
 table_res2 <- rtables::build_table(lyt, airquality)
-card2$append_table(table_res2)
-card2$append_table(iris)
+# https://github.com/davidgohel/flextable/issues/600
+withr::with_options(
+  opts_partial_match_old,
+  {
+    card2$append_table(table_res2)
+    card2$append_table(iris)
+  }
+)
 
 reporter <- Reporter$new()
 reporter$append_cards(list(card1, card2))

tests/testthat/test-Renderer.R

@@ -10,7 +10,11 @@ text_block1 <- TextBlock$new()$set_content("text")$set_style("header2")
 text_block2 <- TextBlock$new()$set_content("text")
 png_path <- system.file("img", "Rlogo.png", package = "png")
 picture_block <- PictureBlock$new()$set_content(ggplot2::ggplot(iris))
-table_block <- TableBlock$new()$set_content(iris)
+# https://github.com/davidgohel/flextable/issues/600
+withr::with_options(
+  opts_partial_match_old,
+  table_block <- TableBlock$new()$set_content(iris)
+)
 newpage_block <- NewpageBlock$new()
 blocks <- list(text_block1, text_block2, picture_block, table_block, newpage_block)
 

tests/testthat/test-ReportCard.R

@@ -16,14 +16,22 @@ testthat::test_that("append_text returns self", {
 })
 
 testthat::test_that("append_table accepts a data.frame", {
-  testthat::expect_no_error(
-    ReportCard$new()$append_table(iris)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    testthat::expect_no_error(
+      ReportCard$new()$append_table(iris)
+    )
   )
 })
 
 testthat::test_that("append_table returns self", {
   card <- ReportCard$new()
-  testthat::expect_identical(card$append_table(iris), card)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    testthat::expect_identical(card$append_table(iris), card)
+  )
 })
 
 testthat::test_that("append_plot returns self", {

tests/testthat/test-Reporter.R

@@ -6,7 +6,7 @@ testthat::test_that("new returns an object of type Reporter", {
   testthat::expect_true(inherits(Reporter$new(), "Reporter"))
 })
 
-card1 <- teal.reporter::ReportCard$new()
+card1 <- ReportCard$new()
 
 card1$append_text("Header 2 text", "header2")
 card1$append_text("A paragraph of default text", "header2")
@@ -15,14 +15,20 @@ card1$append_plot(
     ggplot2::geom_histogram()
 )
 
-card2 <- teal.reporter::ReportCard$new()
+card2 <- ReportCard$new()
 
 card2$append_text("Header 2 text", "header2")
 card2$append_text("A paragraph of default text", "header2")
 lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
 table_res2 <- rtables::build_table(lyt, airquality)
-card2$append_table(table_res2)
-card2$append_table(iris)
+# https://github.com/davidgohel/flextable/issues/600
+withr::with_options(
+  opts_partial_match_old,
+  {
+    card2$append_table(table_res2)
+    card2$append_table(iris)
+  }
+)
 
 reporter <- Reporter$new()
 reporter$append_cards(list(card1, card2))
@@ -51,7 +57,7 @@ testthat::test_that("get_blocks and get_cards return empty list by default", {
 })
 
 testthat::test_that("The deep copy constructor copies the content files to new files", {
-  card <- teal.reporter::ReportCard$new()$append_plot(ggplot2::ggplot(iris))
+  card <- ReportCard$new()$append_plot(ggplot2::ggplot(iris))
   reporter <- Reporter$new()$append_cards(list(card))
   reporter_copy <- reporter$clone(deep = TRUE)
   original_content_file <- reporter$get_blocks()[[1]]$get_content()

tests/testthat/test-TableBlock.R

@@ -8,7 +8,11 @@ testthat::test_that("new returns an object of type TableBlock", {
 
 testthat::test_that("set_content accepts a table object", {
   block <- TableBlock$new()
-  testthat::expect_no_error(block$set_content(iris))
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    testthat::expect_no_error(block$set_content(iris))
+  )
 })
 
 testthat::test_that("set_content asserts the argument is a plot", {
@@ -18,7 +22,11 @@ testthat::test_that("set_content asserts the argument is a plot", {
 
 testthat::test_that("set_content returns the TableBlock object", {
   block <- TableBlock$new()
-  testthat::expect_identical(block$set_content(iris), block)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    testthat::expect_identical(block$set_content(iris), block)
+  )
 })
 
 testthat::test_that("get_content returns character(0) on a newly initialized TableBlock", {
@@ -28,19 +36,31 @@ testthat::test_that("get_content returns character(0) on a newly initialized Tab
 temp_dir <- tempdir()
 
 testthat::test_that("to_list returns a named list with a one field, a proper file name", {
-  block <- TableBlock$new()$set_content(iris)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    block <- TableBlock$new()$set_content(iris)
+  )
   testthat::expect_equal(block$to_list(temp_dir), list(basename = basename(block$get_content())))
 })
 
 # to_list
 testthat::test_that("to_list returns a named list with a one field, a proper path", {
-  tblock <- TableBlock$new()$set_content(iris)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    tblock <- TableBlock$new()$set_content(iris)
+  )
   testthat::expect_identical(tblock$to_list(temp_dir), list(basename = basename(tblock$get_content())))
 })
 
 # from_list
 testthat::test_that("from_list after to_list to save and retrive", {
-  tblock <- TableBlock$new()$set_content(iris)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    tblock <- TableBlock$new()$set_content(iris)
+  )
   testthat::expect_identical(
     file.size(TableBlock$new()$from_list(
       tblock$to_list(temp_dir),
@@ -52,7 +72,11 @@ testthat::test_that("from_list after to_list to save and retrive", {
 
 testthat::test_that("set_content supports data.frame object", {
   block <- TableBlock$new()
-  testthat::expect_no_error(block$set_content(iris))
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    testthat::expect_no_error(block$set_content(iris))
+  )
 })
 
 testthat::test_that("set_content supports rtables object", {
@@ -65,5 +89,9 @@ testthat::test_that("set_content supports rtables object", {
         "range" = diff(range(x))
       )
     })
-  testthat::expect_no_error(block$set_content(rtables::build_table(l, iris)))
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    testthat::expect_no_error(block$set_content(rtables::build_table(l, iris)))
+  )
 })

tests/testthat/test-utils.R

@@ -8,7 +8,11 @@ testthat::test_that("panel_item", {
 
 testthat::test_that("to_flextable: supported class", {
   data_frame <- data.frame(A = 1:3, B = 4:6)
-  flextable_output <- to_flextable(data_frame)
+  # https://github.com/davidgohel/flextable/issues/600
+  withr::with_options(
+    opts_partial_match_old,
+    flextable_output <- to_flextable(data_frame)
+  )
   testthat::expect_s3_class(flextable_output, "flextable")
 })