318: Increase Coverage beyond 80%

DESCRIPTION

@@ -58,6 +58,7 @@ Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate,
     rstudio/rmarkdown, rstudio/shinytest2, rstudio/shinyvalidate,
     r-lib/testthat, r-lib/withr
 Config/Needs/website: insightsengineering/nesttemplate
+Config/testthat/edition: 3
 Encoding: UTF-8
 Language: en-US
 LazyData: true

inst/WORDLIST

@@ -1,9 +1,12 @@
 Closeable
 Draggable
+draggable
 Forkers
+funder
 Hoffmann
+optionalSelectInput
+optionalSliderInput
+optionalSliderInputValMinMax
 POSIXt
-UI
-draggable
-funder
 pre
+UI

tests/testthat.R

@@ -1,3 +1,8 @@
 pkg_name <- "teal.widgets"
 library(pkg_name, character.only = TRUE)
-testthat::test_check(pkg_name)
+if (!is.null(requireNamespace("testthat"))) {
+  library(testthat)
+  test_check(pkg_name)
+} else {
+  message("Please install testthat to run tests")
+}

tests/testthat/_snaps/optionalSliderInputValMinMax_ui.md

@@ -0,0 +1,7 @@
+# snapshot test for optionalSliderInput
+
+    Code
+      as.character(optionalSliderInput("my slider", "my label", 0, 10, 2))
+    Output
+      [1] "<div class=\"form-group shiny-input-container\">\n  <label class=\"control-label\" id=\"my slider-label\" for=\"my slider\">my label</label>\n  <input class=\"js-range-slider\" id=\"my slider\" data-skin=\"shiny\" data-min=\"0\" data-max=\"10\" data-from=\"2\" data-step=\"1\" data-grid=\"true\" data-grid-num=\"10\" data-grid-snap=\"false\" data-prettify-separator=\",\" data-prettify-enabled=\"true\" data-keyboard=\"true\" data-data-type=\"number\"/>\n</div>"
+

tests/testthat/_snaps/verbatim_popup_ui.md

@@ -0,0 +1,7 @@
+# snapshot test for verbatim_popup_ui
+
+    Code
+      verbatim_popup_ui("STH", "STH2")
+    Output
+      <button class="btn btn-default action-button teal-widgets-busy-disable button" id="STH-button" type="button">STH2</button>
+

tests/testthat/_snaps/white_small_well.md

@@ -0,0 +1,7 @@
+# Snapshot test for white_small_well
+
+    Code
+      white_small_well()
+    Output
+      <div class="well well-sm" style="background-color: white;"></div>
+

tests/testthat/test-draggable_buckets.R

@@ -102,3 +102,38 @@ testthat::test_that(
     app_driver$stop()
   }
 )
+
+testthat::test_that("fails when inputId is not from the expected type", {
+  expect_error(
+    draggable_buckets(numeric(1), "test_label", "element_1", "bucket_1"),
+    "Assertion on 'input_id' failed: Must be of type 'string', not 'double'."
+  )
+})
+
+testthat::test_that("fails when label is not from the expected type", {
+  expect_error(
+    draggable_buckets("my_input_id", numeric(), "element_1", "bucket_1"),
+    'Assertion on \'inherits(label, "character") || inherits(label, "shiny.tag")\' failed: Must be TRUE.'
+  )
+})
+
+testthat::test_that("fails when buckets is not from the expected type", {
+  expect_error(draggable_buckets("my_input_id", "test_label", "element_1", numeric()))
+})
+
+testthat::test_that("Snapshot test for ui component draggable buckets", {
+  my_id <- "my_input_id"
+  my_label <- "test_label"
+  dummy_element <- "element_1"
+  dummy_buckets <- "buckets_1"
+  draggable_ui_text <- as.character(draggable_buckets(my_id, my_label, dummy_element, dummy_buckets))
+
+  expect_true(
+    all(c(
+      grepl(my_id, draggable_ui_text),
+      grepl(my_label, draggable_ui_text),
+      grepl(dummy_element, draggable_ui_text),
+      grepl(dummy_buckets, draggable_ui_text)
+    ))
+  )
+})

tests/testthat/test-get_dt_rows_ui.R

@@ -71,3 +71,7 @@ testthat::test_that(
     app_driver$stop()
   }
 )
+
+testthat::test_that("Check class of get_dt_rows", {
+  testthat::expect_s3_class(get_dt_rows("my table", "0"), "shiny.tag")
+})

tests/testthat/test-optionalInput.R

@@ -25,3 +25,118 @@ testthat::test_that("optionalSliderInput min/max NA", {
   testthat::expect_no_error(optionalSliderInput("a", "b", NA, NA, 0.2))
   testthat::expect_no_error(optionalSliderInput("a", "b", 0, 1, 0.2))
 })
+
+testthat::test_that("if inputId is not a string returns an error", {
+  testthat::expect_error(optionalSelectInput(TRUE, "my label", c("choice_1", "choice_2")))
+})
+
+testthat::test_that("if inputId is not a string returns an error", {
+  testthat::expect_error(optionalSelectInput(TRUE, "my label", c("choice_1", "choice_2")))
+})
+
+testthat::test_that("if label is not a string returns an error", {
+  testthat::expect_error(optionalSelectInput("my_input_id", TRUE, c("choice_1", "choice_2")))
+})
+
+testthat::test_that("if with is not a valid css unit returns an error", {
+  testthat::expect_error(
+    optionalSelectInput("my_input_id", "my label", c("choice_1", "choice_2"), width = "wrong css unit")
+  )
+})
+
+testthat::test_that("if options is not a list returns an error", {
+  testthat::expect_error(optionalSelectInput("my_input_id", "my label", c("choice_1", "choice_2"), options = TRUE))
+})
+
+
+testthat::test_that("optionalSelectInput is a Shiny ui component", {
+  testthat::expect_s3_class(
+    optionalSelectInput(
+      "my_input_id",
+      "my label",
+      c("choice_1", "choice_2"),
+      label_help = shiny::helpText("This is a sample help text")
+    ),
+    "shiny.tag"
+  )
+})
+
+testthat::test_that("if inputId is not a string optionalSliderInputValMinMax returns error", {
+  testthat::expect_error(optionalSliderInputValMinMax(
+    list,
+    "label",
+    c(5, 1, 10),
+    label_help = shiny::helpText("Help")
+  ))
+})
+
+testthat::test_that("value_min_max with invalid length throws error", {
+  testthat::expect_error(optionalSliderInputValMinMax("id", "label", c(1, 2)))
+})
+
+testthat::test_that("value out of range in value_min_max throws error", {
+  testthat::expect_error(
+    optionalSliderInputValMinMax("id", "label", c(10, 1, 5)),
+    "value_min_max"
+  )
+})
+
+testthat::test_that("optionalSliderInputValMinMax is a Shiny ui component", {
+  testthat::expect_s3_class(
+    optionalSliderInputValMinMax(
+      "id",
+      "label",
+      c(5, 1, 10),
+      label_help = shiny::helpText("Help")
+    ),
+    "shiny.tag"
+  )
+})
+
+# Tests for updateOptionalSelectInput
+testthat::test_that("updateOptionalSelectInput updates choices and selected values", {
+  # Create a simple server module that uses optionalSelectInput
+  test_module <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      # Expose a way to trigger updates
+      observeEvent(input$trigger_update, {
+        updateOptionalSelectInput(
+          session = session,
+          inputId = "test_select",
+          choices = c("new1", "new2", "new3"),
+          selected = "new2"
+        )
+      })
+
+      # Return the current input value so we can test it
+      reactive({
+        list(
+          value = input$test_select,
+          triggered = input$trigger_update
+        )
+      })
+    })
+  }
+
+  shiny::testServer(test_module, {
+    # Set initial value with original choices
+    session$setInputs(test_select = "old1")
+
+    # Verify initial state
+    result <- session$returned()
+    testthat::expect_equal(result$value, "old1")
+    testthat::expect_null(result$triggered)
+
+    # Trigger the update
+    session$setInputs(trigger_update = 1)
+
+    # After update, the selected value should change to "new2"
+    # Note: In testServer, we need to manually set the input to the new value
+    # since updateOptionalSelectInput sends the update to the client
+    session$setInputs(test_select = "new2")
+
+    result_after <- session$returned()
+    testthat::expect_equal(result_after$value, "new2")
+    testthat::expect_equal(result_after$triggered, 1)
+  })
+})

tests/testthat/test-optionalSelectInput_ui.R

@@ -128,3 +128,111 @@ testthat::test_that(
     app_driver$stop()
   }
 )
+
+testthat::test_that("Check optionalSelectInput is created with different sep", {
+  id <- "my_select_input"
+  label <- "my_label"
+  choices <- c("choice_1", "choice_2")
+  sep <- "|=|"
+  text_optional_select_input <- as.character(optionalSelectInput(id, label, choices, sep = sep))
+
+  expect_true(
+    all(
+      c(
+        grepl(id, text_optional_select_input),
+        grepl(label, text_optional_select_input),
+        grepl(sep, text_optional_select_input)
+      )
+    )
+  )
+})
+
+testthat::test_that("Check optionalSelectInput is created with label_help", {
+  id <- "my_select_input"
+  label <- "my_label"
+  choices <- c("choice_1", "choice_2")
+  label_help <- shiny::helpText("help dummy text")
+  text_optional_select_input <- as.character(
+    optionalSelectInput(id, label, choices, label_help = label_help)
+  )
+
+  expect_true(
+    all(
+      c(
+        grepl(id, text_optional_select_input),
+        grepl(label, text_optional_select_input),
+        grepl(as.character(label_help), text_optional_select_input)
+      )
+    )
+  )
+})
+
+testthat::test_that("Check optionalSelectInput width is applied", {
+  id <- "my_select_input"
+  label <- "my_label"
+  choices <- c("choice_1", "choice_2")
+  width <- "200px"
+  text_optional_select_input <- as.character(optionalSelectInput(id, label, choices, width = width))
+
+  expect_true(
+    all(
+      c(
+        grepl(id, text_optional_select_input),
+        grepl(label, text_optional_select_input),
+        grepl(as.character(width), text_optional_select_input)
+      )
+    )
+  )
+})
+
+
+testthat::test_that("Check options for optionalSelectInput are applied", {
+  id <- "my_select_input"
+  label <- "my_label"
+  choices <- c("choice_1", "choice_2")
+  options <- list("live-search" = FALSE)
+  text_optional_select_input <- as.character(optionalSelectInput(id, label, choices, options = options))
+
+  expect_true(
+    all(
+      c(
+        grepl(id, text_optional_select_input),
+        grepl(label, text_optional_select_input),
+        grepl("live-search", text_optional_select_input)
+      )
+    )
+  )
+})
+
+
+testthat::test_that("Check that choices are empty if not introduced by user", {
+  id <- "my_select_input"
+  label <- "my_label"
+  expect_true(grepl("option value=\"\"", as.character(optionalSelectInput(id, label))))
+})
+
+testthat::test_that("selected marks the initial choice", {
+  id <- "my_select_input"
+  label <- "my_label"
+  choices <- c("choice_1", "choice_2")
+  selected <- choices[1]
+  text_to_find <- paste0("selected>", selected)
+  optional_select_input_text <- as.character(optionalSelectInput(id, label, choices, selected))
+  expect_true(grepl(text_to_find, optional_select_input_text))
+})
+
+testthat::test_that("there is js show hide functionality only if fixed on single is TRUE and length is more than one", {
+  js_on_single_text <- "hide"
+
+  id <- "my_select_input"
+  label <- "my_label"
+  choices <- c("choice_1", "choice_2")
+  text_not_fixed_on_single <- as.character(
+    optionalSelectInput(id, label, choices, fixed_on_single = FALSE)
+  )
+  text_fixed_on_single <- as.character(
+    optionalSelectInput(id, label, choices, fixed_on_single = TRUE)
+  )
+  expect_false(grepl("hide", text_not_fixed_on_single))
+  expect_true(grepl("hide", text_fixed_on_single))
+})

tests/testthat/test-optionalSliderInputValMinMax_ui.R

@@ -25,3 +25,17 @@ testthat::test_that(
     app_driver$stop()
   }
 )
+
+testthat::test_that("we create label help for optionalSliderInputValMinMax", {
+  help_text <- "my-help"
+  text_slider_input_min_max <- as.character(
+    optionalSliderInputValMinMax("my slider", "my label", 2, label_help = shiny::helpText(help_text))
+  )
+  expect_true(grepl(help_text, text_slider_input_min_max))
+})
+
+testthat::test_that("snapshot test for optionalSliderInput", {
+  testthat::skip_if_not_installed("whitr")
+  withr::local_seed(1)
+  testthat::expect_snapshot(as.character(optionalSliderInput("my slider", "my label", 0, 10, 2)))
+})

tests/testthat/test-standard_layout.R

@@ -27,3 +27,26 @@ testthat::test_that("Input validation", {
     post_output = 1
   ), regexp = "Assertion on 'post_output' failed")
 })
+
+describe("Tests for standard_layout options", {
+  mock_output <- shiny::plotOutput("test")
+  mock_form <- shiny::actionButton("test", "")
+
+  it("checks that the class is correct", {
+    # Given
+    expected_class <- "bslib_page"
+    mock_layout <- standard_layout(output = mock_output, encoding = NULL, forms = mock_form)
+
+    # Then
+    expect_true(any(expected_class %in% class(mock_layout)))
+  })
+
+  it("checks snapshot with encoding and null forms", {
+    # Given
+    mock_layout <- standard_layout(output = mock_output, encoding = mock_form, forms = NULL)
+    testthat::skip_if_not_installed("withr")
+    withr::local_seed(1)
+    # Then
+    expect_true(grepl(as.character(mock_form), as.character(mock_layout)))
+  })
+})