Merge pull request #132 from stl2137/2023-fall-hackathon_bstfun-unit-…

…testing

2023 fall hackathon bstfun unit testing

README.md

@@ -26,3 +26,4 @@ You can install the development version of {bstfun} with:
 ``` r
 devtools::install_github("MSKCC-Epi-Bio/bstfun")
 ```
+

tests/testthat/test-add_inline_forest_plot.R

@@ -0,0 +1,22 @@
+test_that("add_inline_forest_plot function works", {
+  expect_error(add_inline_forest_plot_ex1 <-
+    lm(mpg ~ cyl + am + drat, mtcars) %>%
+    gtsummary::tbl_regression() %>%
+    add_inline_forest_plot(),
+    NA
+    )
+
+  # error thrown when class is not gtsummary
+  expect_error(add_inline_forest_plot_ex1 <-
+                 lm(mpg ~ cyl + am + drat, mtcars) %>%
+                 add_inline_forest_plot(),
+               "`x=` must be class 'gtsummary'"
+  )
+
+  # error thrown when table does not contain estimate, or CI's
+  expect_error(add_inline_forest_plot_ex1 <-
+                 gtsummary::tbl_summary(mtcars[c("cyl", "am", "drat")]) %>%
+                 add_inline_forest_plot(),
+               "`x$table_body` must contain columns 'estimate', 'conf.low', 'conf.high'", fixed = TRUE
+  )
+})

tests/testthat/test-add_sparkline.R

@@ -16,4 +16,32 @@ test_that("add_sparkline() works", {
     tbl %>% add_sparkline(column_header = letters)
   )
 
+### expecting "stop("`x=` must be class 'tbl_summary'", call. = FALSE)" works
+  tbl_regression_ex <-
+    gtsummary::tbl_uvregression(
+      trial[c("response", "age", "grade")],
+      method = glm,
+      y = response,
+      method.args = list(family = binomial),
+      exponentiate = TRUE
+    )
+
+  expect_error(
+    add_sparkline(tbl_regression_ex),
+    "`x=` must be class 'tbl_summary'", fixed = TRUE
+  )
+
+### expecting message to be thrown
+  tbl_by <-
+    trial[c("age", "marker", "response")] %>%
+    gtsummary::tbl_summary(
+      by = response,
+      missing = "always"
+    )
+
+  expect_message(
+    tbl_by %>% add_sparkline(),
+    "Input table is stratified, but sparkline figure is not."
+  )
 })
+

tests/testthat/test-add_splines.R

@@ -24,5 +24,12 @@ test_that("add_spline function gives error if spline variable names exist", {
     "*"
   )
 
-
+  # Error if new_names does not have same length as the number of new column
+  expect_error(
+    gtsummary::trial %>%
+      add_splines(variable = age, new_names = c("sptest1", "sptest2")) %>%
+      add_splines(variable = age, new_names = c("sptest1", "sptest2", "sptest3")),
+        "`new_names=` must be the same length as the number of new columns (n = 3)", fixed = TRUE
+)
 })
+

tests/testthat/test-add_variable_grouping.R

@@ -17,4 +17,28 @@ test_that("add_variable_grouping() works", {
         "Race (check all that apply)" = c("race_asian", "race_black", "race_white")),
     NA
   )
+
+  expect_error(
+    data.frame(
+      race_asian = sample(c(TRUE, FALSE), 20, replace = TRUE),
+      race_black = sample(c(TRUE, FALSE), 20, replace = TRUE),
+      race_white = sample(c(TRUE, FALSE), 20, replace = TRUE),
+      age = rnorm(20, mean = 50, sd = 10)
+    ) %>%
+      add_variable_grouping(
+        "Race (check all that apply)" = c("race_asian", "race_black", "race_white")),
+    "`x=` must be class 'gtsummary'."
+  )
+
+  expect_error(
+    data.frame(
+    race_asian = sample(c(TRUE, FALSE), 20, replace = TRUE),
+    race_black = sample(c(TRUE, FALSE), 20, replace = TRUE),
+    race_white = sample(c(TRUE, FALSE), 20, replace = TRUE),
+    age = rnorm(20, mean = 50, sd = 10)
+  ) %>%
+    gtsummary::tbl_summary(
+    ) %>%
+    add_variable_grouping("")
+  )
 })

tests/testthat/test-as_forest_plot.R

@@ -13,4 +13,17 @@ test_that("as_forest_plot() works", {
       as_forest_plot(),
     NA
   )
+
+### ensuring "Error: `x=` must be class 'tbl_regression' or 'tbl_uvregression'"
+  expect_error((
+    tbl_summary(
+      trial[c("response", "age", "grade")],
+      by = "response")
+  ) %>%
+    as_forest_plot(),
+  "`x=` must be class 'tbl_regression' or 'tbl_uvregression'"
+  )
 })
+
+
+

tests/testthat/test-as_ggplot.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-assign_timepoint.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-auc.R

@@ -8,4 +8,12 @@ test_that("No errors/warnings with standard use", {
     runif(10000) %>% hist(breaks = 250) %>% auc_histogram(),
     NA
   )
+
+### ensuring auc_histogram throws correct error w/ non hist object
+  expect_error(
+    runif(10000) %>%
+      barplot() %>%
+      auc_histogram(),
+    "`x=` must be class 'histogram' created with `hist()`", fixed = TRUE
+  )
 })

tests/testthat/test-bold_italicize_group_labels.R

@@ -6,14 +6,14 @@ test_that("bold_italicize_group_labels_gt_works", {
     bold_italicize_group_labels_ex1 <-
       trial %>%
       select(age, trt, grade) %>%
-      tbl_strata(
+      gtsummary::tbl_strata(
         strata = grade,
         ~ .x %>%
           select(trt, age) %>%
-          tbl_summary(by = trt, missing = "no"),
+          gtsummary::tbl_summary(by = trt, missing = "no"),
         .combine_with = "tbl_stack"
       ) %>%
-      bold_italicize_group_labels(bold = TRUE, "gt"),
+      bold_italicize_group_labels(bold = TRUE, italics = TRUE, "gt"),
     NA
   )
 })
@@ -23,14 +23,14 @@ test_that("bold_italicize_group_labels_flextable_works", {
     bold_italicize_group_labels_ex1 <-
       trial %>%
       select(age, trt, grade) %>%
-      tbl_strata(
+      gtsummary::tbl_strata(
         strata = grade,
         ~ .x %>%
           select(trt, age) %>%
-          tbl_summary(by = trt, missing = "no"),
+          gtsummary::tbl_summary(by = trt, missing = "no"),
         .combine_with = "tbl_stack"
       ) %>%
-      bold_italicize_group_labels(bold = TRUE, "flextable"),
+      bold_italicize_group_labels(bold = TRUE, italics = TRUE, "flextable"),
     NA
   )
 })
@@ -40,15 +40,23 @@ test_that("bold_italicize_group_labels_huxtable_works", {
     bold_italicize_group_labels_ex1 <-
       trial %>%
       select(age, trt, grade) %>%
-      tbl_strata(
+      gtsummary::tbl_strata(
         strata = grade,
         ~ .x %>%
           select(trt, age) %>%
-          tbl_summary(by = trt, missing = "no"),
+          gtsummary::tbl_summary(by = trt, missing = "no"),
         .combine_with = "tbl_stack"
       ) %>%
-      bold_italicize_group_labels(bold = TRUE, "huxtable"),
+      bold_italicize_group_labels(bold = TRUE, italics = TRUE, "huxtable"),
     NA
   )
 })
 
+test_that("bold_italicize_group_labels overall function works", {
+  expect_error(
+      trial %>%
+      select(age, trt, grade) %>%
+      bold_italicize_group_labels(bold = TRUE),
+    "Class of 'x' must be 'gtsummary'"
+  )
+})

tests/testthat/test-fix_database_error.R

@@ -97,5 +97,3 @@ test_that("fix_database_error does not allow non-logical expressions in `id`", {
     "*"
   )
 })
-
-

tests/testthat/test-here_data.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-hpcc.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-is_hot.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-rm_logs.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-style_tbl_compact.R

@@ -26,4 +26,12 @@ test_that("no errors with typical use", {
       style_tbl_compact(),
     NA
   )
+
+  expect_error(
+    head(trial) %>%
+      style_tbl_compact(),
+    "`data=` must be a {gt}, {flextable}, {huxtable}, or `knitr::kable()` table.", fixed = TRUE
+  )
+
+
 })

tests/testthat/test-tbl_likert.R

@@ -9,6 +9,22 @@ df <-
       factor(levels = 1:3, labels = c("bad", "meh", "good")),
   )
 
+### expecting class is the same
+test_that("data for tbl_likert() works", {
+  expect_equal(
+    str(df),
+    df %>%
+      mutate(
+        dplyr::across(
+          .cols = everything(),
+          function(.x){
+            if (inherits(.x, "factor")) return(.x)
+            factor(.x)
+          }
+        )
+      ) %>% str()
+  )
+})
 
 test_that("tbl_likert() works", {
   expect_error(
@@ -30,6 +46,8 @@ test_that("tbl_likert() works", {
       dplyr::pull(label),
     c("f2", "f1")
   )
+
+
 })
 
 test_that("add_n.tbl_likert() works", {
@@ -55,6 +73,8 @@ test_that("add_n.tbl_likert() works", {
     tbl %>% add_n(last = TRUE) %>% gtsummary::as_tibble() %>% dplyr::pull(5),
     c("100", "100")
   )
+
+
 })
 
 

tests/testthat/test-use_bst_file.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-use_bst_rstudio_prefs.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})

tests/testthat/test-utils-fix_database_error.R

@@ -0,0 +1,3 @@
+test_that("multiplication works", {
+  expect_equal(2 * 2, 4)
+})