Merge pull request #158 from atorus-research/157-clean-tests-output

Closes #157 Clean tests output

R/support-test.R

@@ -5,6 +5,7 @@
 #' column width.
 #'
 #' @return The first argument, invisibly.
+#' @keywords internal
 expect_attr_width <- function(result, metadata_length) {
   test_widths <- map(
     colnames(result), ~ attributes(result[[.x]]) %>% pluck("width")
@@ -28,6 +29,7 @@ expect_attr_width <- function(result, metadata_length) {
 #' By default only `x` and `y` are returned with numeric contents.
 #'
 #' @return A data.frame mimicking a valid ADaM dataset.
+#' @keywords internal
 minimal_table <- function(n_rows = 3, cols = c("x", "y")) {
   data.frame(
     x = sample(1000 + seq(n_rows * 100), size = n_rows),
@@ -68,6 +70,7 @@ minimal_table <- function(n_rows = 3, cols = c("x", "y")) {
 #' to keep
 #'
 #' @return A metadata data.frame
+#' @keywords internal
 minimal_metadata <- function(dataset = FALSE,
                              length = FALSE,
                              label = FALSE,
@@ -100,17 +103,32 @@ minimal_metadata <- function(dataset = FALSE,
   metadata %>% select(all_of(cols))
 }
 
-#' Theme for cli package messages when running inside tests
+
+#' Local function to remove extra spaces and format by cli
+#'
+#' Groups together multiple calls instead of being spread out in code
 #'
-#' It can be defined with starting an `cli::start_app(theme = cli_theme_tests)`
-cli_theme_tests <- list(
-  h2 = list(`margin-top` = 0, `margin-bottom` = 0)
-)
+#' @param `[environment(1)]`\cr Attach exit handlers to this environment. Typically, this should
+#' be either the current environment or a parent frame
+#' (accessed through parent.frame()).
+#' @keywords internal
+local_cli_theme <- function(.local_envir = parent.frame()) {
+  cli_theme_tests <- list(
+    h2 = list(`margin-top` = 0, `margin-bottom` = 0, fmt = function(x) x),
+    h1 = list(`margin-top` = 0, `margin-bottom` = 0, fmt = function(x) x),
+    `.alert` = list(before = NULL),
+    `.alert-danger` = list(before = NULL),
+    `.alert-success` = list(before = NULL)
+  )
+
+  withr::local_options(list(cli.user_theme = cli_theme_tests), .local_envir = .local_envir)
+  withr::local_envvar(list(NO_COLOR = "yes"), .local_envir = .local_envir)
+  app <- cli::start_app(output = "message", .auto_close = FALSE)
+  withr::defer(cli::stop_app(app), envir = .local_envir)
+}
 
 #' Test if multiple vars in spec will result in warning message
-#' @noRd
-#' @examples
-#' multiple_vars_in_spec_helper(xportr_order)
+#' @keywords internal
 multiple_vars_in_spec_helper <- function(FUN) {
   adsl <- minimal_table(30)
   metadata <- minimal_metadata(
@@ -128,21 +146,17 @@ multiple_vars_in_spec_helper <- function(FUN) {
     dplyr::bind_rows(metadata) %>%
     dplyr::rename(Dataset = "dataset")
 
+  withr::local_options(list(xportr.length_verbose = "message"))
   # Setup temporary options with active verbose and Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests, xportr.length_verbose = "message"))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   adsl %>%
     FUN(metadata) %>%
     testthat::expect_message("There are multiple specs for the same variable name")
 }
 
 #' Test if multiple vars in spec with appropriate
-#' @noRd
-#' @examples
-#' multiple_vars_in_spec_helper2(xportr_order)
-#'
+#' @keywords internal
 multiple_vars_in_spec_helper2 <- function(FUN) {
   adsl <- minimal_table(30)
   metadata <- minimal_metadata(
@@ -160,15 +174,9 @@ multiple_vars_in_spec_helper2 <- function(FUN) {
     dplyr::bind_rows(metadata) %>%
     dplyr::rename(Dataset = "dataset")
 
+  withr::local_options(list(xportr.length_verbose = "message", xportr.domain_name = "Dataset"))
   # Setup temporary options with active verbose and Remove empty lines in cli theme
-  withr::local_options(list(
-    cli.user_theme = cli_theme_tests,
-    xportr.length_verbose = "message",
-    xportr.domain_name = "Dataset"
-  ))
-
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   adsl %>%
     FUN(metadata) %>%

_pkgdown.yml

@@ -44,15 +44,9 @@ reference:
       - adsl
       - var_spec
 
-  - title: internal
-    contents:
-      - cli_theme_tests
-      - expect_attr_width
-      - minimal_metadata
-      - minimal_table
-
 articles:
   - title: ~
     navbar: ~
     contents:
       - deepdive
+

tests/testthat/test-depreciation.R

@@ -6,10 +6,8 @@ test_that("xportr_df_label: deprecated metacore argument still works and gives w
   df_spec_labeled_df <- xportr_df_label(df, metacore = df_meta)
 
   expect_equal(attr(df_spec_labeled_df, "label"), "Label")
-  lifecycle::expect_deprecated(
-    xportr_df_label(df, metacore = df_meta),
-    "Please use the `metadata` argument instead."
-  )
+  xportr_df_label(df, metacore = df_meta) %>%
+    lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
 })
 
 test_that("xportr_format: deprecated metacore argument still works and gives warning", {
@@ -24,23 +22,26 @@ test_that("xportr_format: deprecated metacore argument still works and gives war
   formatted_df <- xportr_format(df, metacore = df_meta)
 
   expect_equal(attr(formatted_df$x, "format.sas"), "DATE9.")
-  lifecycle::expect_deprecated(
-    xportr_format(df, metacore = df_meta),
-    "Please use the `metadata` argument instead."
-  )
+  xportr_format(df, metacore = df_meta) %>%
+    lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
 })
 
 test_that("xportr_label: deprecated metacore argument still works and gives warning", {
   withr::local_options(lifecycle_verbosity = "quiet")
+
   df <- data.frame(x = "a", y = "b")
   df_meta <- data.frame(dataset = "df", variable = "x", label = "foo")
 
-  df_labeled_df <- xportr_label(df, metacore = df_meta)
+  df_labeled_df <- suppressMessages(
+    xportr_label(df, metacore = df_meta)
+  )
 
   expect_equal(attr(df_labeled_df$x, "label"), "foo")
-  lifecycle::expect_deprecated(
-    xportr_label(df, metacore = df_meta),
-    "Please use the `metadata` argument instead."
+
+  # Note that only the deprecated message should be caught (others are ignored)
+  suppressMessages(
+    xportr_label(df, metacore = df_meta) %>%
+      lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
   )
 })
 
@@ -57,27 +58,31 @@ test_that("xportr_length: deprecated metacore argument still works and gives war
   df_with_width <- xportr_length(df, metacore = df_meta)
 
   expect_equal(c(x = 1, y = 2), map_dbl(df_with_width, attr, "width"))
-  lifecycle::expect_deprecated(
-    xportr_length(df, metacore = df_meta),
-    "Please use the `metadata` argument instead."
-  )
+
+  xportr_length(df, metacore = df_meta) %>%
+    lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
 })
 
 test_that("xportr_order: deprecated metacore argument still works and gives warning", {
   withr::local_options(lifecycle_verbosity = "quiet")
+
   df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5])
   df_meta <- data.frame(
     dataset = "DOMAIN",
     variable = letters[1:4],
     order = 1:4
   )
 
-  ordered_df <- xportr_order(df, metacore = df_meta, domain = "DOMAIN")
+  ordered_df <- suppressMessages(
+    xportr_order(df, metacore = df_meta, domain = "DOMAIN")
+  )
 
   expect_equal(names(ordered_df), df_meta$variable)
-  lifecycle::expect_deprecated(
-    xportr_order(df, metacore = df_meta),
-    "Please use the `metadata` argument instead."
+
+  # Note that only the deprecated message should be caught (others are ignored)
+  suppressMessages(
+    xportr_order(df, metacore = df_meta) %>%
+      lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
   )
 })
 
@@ -96,9 +101,13 @@ test_that("xportr_type: deprecated metacore argument still works and gives warni
     format = NA
   )
 
-  df2 <- xportr_type(df, metacore = df_meta)
-  lifecycle::expect_deprecated(
-    xportr_type(df, metacore = df_meta),
-    "Please use the `metadata` argument instead."
+  df2 <- suppressMessages(
+    xportr_type(df, metacore = df_meta)
+  )
+
+  # Note that only the deprecated message should be caught (others are ignored)
+  suppressMessages(
+    xportr_type(df, metacore = df_meta) %>%
+      lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
   )
 })

tests/testthat/test-length.R

@@ -5,7 +5,6 @@
 #' * Result of call will create `SASlength` attribute (`width` for each
 #' variable)
 
-
 test_that("xportr_length: Accepts valid domain names in metadata object", {
   adsl <- minimal_table(30)
   metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = colnames(adsl))
@@ -68,9 +67,7 @@ test_that("xportr_length: CDISC data frame domain is being recognized from pipe"
   withr::local_options(list(xportr.length_verbose = "message"))
 
   # Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   # With domain manually set
   not_adsl <- adsl
@@ -108,9 +105,7 @@ test_that("xportr_length: Impute character lengths based on class", {
   withr::local_options(list(xportr.character_types = c("character", "date")))
 
   # Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   # Test length imputation of character and numeric (not valid character type)
   result <- adsl %>%
@@ -142,9 +137,7 @@ test_that("xportr_length: Throws message when variables not present in metadata"
   # Setup temporary options with `verbose = "message"`
   withr::local_options(list(xportr.length_verbose = "message"))
   # Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   # Test that message is given which indicates that variable is not present
   xportr_length(adsl, metadata) %>%

tests/testthat/test-messages.R

@@ -20,9 +20,7 @@ test_that("xportr_logger: Type parameter will create correct message type", {
 
 test_that("length_log: Missing lengths messages are shown", {
   # Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   length_log(c("var1", "var2", "var3"), "message") %>%
     expect_message("Variable lengths missing from metadata.") %>%
@@ -32,9 +30,7 @@ test_that("length_log: Missing lengths messages are shown", {
 
 test_that("length_log: Missing variables messages are shown", {
   # Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   label_log(c("var1", "var2", "var3"), "message") %>%
     # cli messages
@@ -46,9 +42,7 @@ test_that("length_log: Missing variables messages are shown", {
 
 test_that("var_names_log: Renamed variables messages are shown", {
   # Remove empty lines in cli theme
-  withr::local_options(list(cli.user_theme = cli_theme_tests))
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app))
+  local_cli_theme()
 
   tidy_names_df <- data.frame(
     original_varname = c("var1", "var2", "var3", "var4", "VAR5", "VAR6"),