Add unit tests for bslib::tooltip()

inst/apps/314-bslib-tooltips/app.R

@@ -0,0 +1,131 @@
+library(shiny)
+library(bslib)
+library(plotly)
+
+ui <- page_navbar(
+  title = "Tooltip tests",
+  fillable = FALSE,
+  id = "navbar",
+  theme = bs_theme("tooltip-bg" = "#232529"),
+
+  nav_panel(
+    "Tooltip cases",
+    inputPanel(
+      class = "px-3 py-5",
+      h3("Placement"),
+      tooltip(
+        a("auto", id = "tip-auto", href = "#"),
+        "Tooltip title"
+      ),
+      tooltip(
+        a("left", id = "tip-left", href = "#"),
+        "Tooltip title",
+        placement = "left"
+      ),
+      tooltip(
+        a("right", id = "tip-right", href = "#"),
+        "Tooltip title",
+        placement = "right"
+      ),
+      tooltip(
+        a("top", id = "tip-top", href = "#"),
+        "Tooltip title",
+        placement = "top"
+      ),
+      tooltip(
+        a("bottom", id = "tip-bottom", href = "#"),
+        "Tooltip title",
+        placement = "bottom"
+      )
+    ),
+
+    inputPanel(
+      class = "px-3 py-5",
+      h3("Triggers"),
+      tooltip(id = "tip-hello",
+        "Hello tooltip",
+        "Tooltip message"
+      ),
+      tooltip(id = "tip-inline",
+        span("Inline tooltip"),
+        "Tooltip message"
+      ),
+      tooltip(id = "tip-action",
+        actionButton("btn", "A button"),
+        "Tooltip 1"
+      ),
+      tooltip(id = "tip-multiple",
+        tagList(
+          actionButton("btn2", "A button"),
+          actionButton("btn3", "A button"),
+        ),
+        "A tooltip"
+      )
+    ),
+
+    inputPanel(
+      class = "px-3 py-5",
+      h3("Options"),
+      tooltip(
+        span("Offset (50,50)", id = "tip-offset"),
+        "This tip should appear 50px down/right",
+        placement = "right",
+        options = list(offset = c(50, 50))
+      ),
+      tooltip(
+        span("Offset (50,50)", id = "tip-animation"),
+        "This tip shouldn't fade in/out",
+        placement = "right",
+        options = list(animation = FALSE)
+      )
+    ),
+
+  ),
+
+  nav_panel(
+    "Tooltip updates",
+    layout_sidebar(
+      card(
+        card_header(
+          span(
+            "Card title with tooltip",
+            bsicons::bs_icon("question-circle-fill")
+          ) |>
+            tooltip(
+              "Tooltip message", id = "tooltip",
+              placement = "right"
+            )
+        ),
+        plotlyOutput("bars")
+      ),
+      sidebar = list(
+        textInput("tooltip_msg", "Enter a tooltip message", "Tooltip message"),
+        actionButton("show_tooltip", "Show tooltip", class = "mb-3"),
+        actionButton("hide_tooltip", "Hide tooltip")
+      )
+    )
+  ),
+)
+
+server <- function(input, output, session) {
+
+  observeEvent(input$tooltip_msg, {
+    update_tooltip("tooltip", input$tooltip_msg)
+  })
+
+  observeEvent(input$show_tooltip, {
+    toggle_tooltip("tooltip", show = TRUE)
+  })
+
+  observeEvent(input$hide_tooltip, {
+    toggle_tooltip("tooltip", show = FALSE)
+  })
+
+  output$bars <- renderPlotly({
+    plot_ly(diamonds, x = ~cut)
+  })
+
+}
+
+shinyApp(ui, server)
+

inst/apps/314-bslib-tooltips/tests/testthat.R

@@ -0,0 +1 @@
+shinytest2::test_app()

inst/apps/314-bslib-tooltips/tests/testthat/setup-shinytest2.R

@@ -0,0 +1,3 @@
+# Load application support files into testing environment
+shinytest2::load_app_env()
+

inst/apps/314-bslib-tooltips/tests/testthat/test-314-bslib-tooltips.R

@@ -0,0 +1,158 @@
+library(shinytest2)
+
+# Only take screenshots on mac + r-release to reduce diff noise
+release <- rversions::r_release()$version
+release <- paste0(
+  strsplit(release, ".", fixed = TRUE)[[1]][1:2],
+  collapse = "."
+)
+
+is_testing_on_ci <- identical(Sys.getenv("CI"), "true") && testthat::is_testing()
+is_mac_release <- identical(paste0("mac-", release), platform_variant())
+
+DO_SCREENSHOT <- is_testing_on_ci && is_mac_release
+
+
+source(system.file("helpers", "keyboard.R", package = "shinycoreci"))
+
+expect_focus <- function(app, selector) {
+  js <- sprintf(
+    "document.activeElement == document.querySelector('%s')",
+    selector
+  )
+  expect_true(app$get_js(!!js))
+  invisible(app)
+}
+
+# Setup App  ------------------------------------------------
+app <- AppDriver$new(
+  name = "314-bslib-tooltips",
+  variant = platform_variant(),
+  height = 800,
+  width = 1200,
+  seed = 20230714,
+  view = interactive(),
+  options = list(bslib.precompiled = FALSE),
+  expect_values_screenshot_args = FALSE,
+  screenshot_args = list(selector = "viewport", delay = 0.5)
+)
+withr::defer(app$stop())
+
+key_press <- key_press_factory(app)
+
+
+# Tests for the 1st tab (Tooltip cases)
+test_that("Can tab focus various cases/options", {
+  expect_focus(app, "body")
+
+  key_press("Tab")
+  expect_focus(app, ".nav-link.active")
+
+  # Before focusing any tooltips, set up an event handler to keep track of
+  # the last tooltip shown
+  app$run_js(
+    '$(document).on("shown.bs.tooltip", function(e) { window.lastShown = e.target; });'
+  )
+
+  # lastShown should contain the trigger element, which we can use to find the
+  # actual tooltip (we just make sure it's visible).
+  expect_visible_tip <- function(app, selector) {
+    app$wait_for_js(
+      sprintf("window.lastShown === document.querySelector('%s')", selector)
+    )
+    app$wait_for_js(
+      "var tipId = window.lastShown.getAttribute('aria-describedby');
+      $(`#${tipId}:visible`).length > 0;"
+    )
+  }
+
+  # Placement ----------------------------------
+  key_press("Tab")
+  expect_focus(app, "#tip-auto")
+  expect_visible_tip(app, "#tip-auto")
+
+  key_press("Tab")
+  expect_focus(app, "#tip-left")
+  expect_visible_tip(app, "#tip-left")
+
+  key_press("Tab")
+  expect_focus(app, "#tip-right")
+  expect_visible_tip(app, "#tip-right")
+
+  key_press("Tab")
+  expect_focus(app, "#tip-top")
+  expect_visible_tip(app, "#tip-top")
+
+  key_press("Tab")
+  expect_focus(app, "#tip-bottom")
+  expect_visible_tip(app, "#tip-bottom")
+
+  # Triggers ----------------------------------
+  key_press("Tab")
+  expect_focus(app, "#tip-hello span")
+  expect_visible_tip(app, "#tip-hello span")
+
+  key_press("Tab")
+  expect_focus(app, "#tip-inline span")
+  expect_visible_tip(app, "#tip-inline span")
+
+  key_press("Tab")
+  expect_focus(app, "#tip-action button")
+  expect_visible_tip(app, "#tip-action button")
+
+  key_press("Tab")
+  key_press("Tab")
+  expect_focus(app, "#tip-multiple :last-child")
+  expect_visible_tip(app, "#tip-multiple :last-child")
+
+  # Options ----------------------------------
+  key_press("Tab")
+  expect_focus(app, "#tip-offset")
+  expect_visible_tip(app, "#tip-offset")
+
+  if (DO_SCREENSHOT) app$expect_screenshot()
+
+  key_press("Tab")
+  expect_focus(app, "#tip-animation")
+  expect_visible_tip(app, "#tip-animation")
+})
+
+
+
+# Tests for the 2nd tab (Tooltip cases)
+test_that("Can programmatically update/show/hide tooltip", {
+
+  expect_no_tip <- function(app) {
+    app$wait_for_js("$('.tooltip:visible').length === 0")
+  }
+
+  expect_tip_message <- function(app, msg) {
+    app$wait_for_js(
+      sprintf(
+        "document.querySelector('.tooltip-inner').innerText === '%s'",
+        msg
+      )
+    )
+  }
+
+  app$set_inputs("navbar" = "Tooltip updates")
+
+  app$click("show_tooltip")
+  expect_visible_tip(app, "#tooltip span")
+
+  app$set_inputs("tooltip_msg" = "new")
+  expect_tip_message(app, "new")
+
+  app$click("hide_tooltip")
+  expect_no_tip(app)
+
+  app$set_inputs("tooltip_msg" = "newer")
+  expect_tip_message(app, "newer")
+
+  app$click("show_tooltip")
+  expect_visible_tip(app, "#tooltip span")
+  expect_tip_message(app, "newer")
+
+  app$set_inputs("navbar" = "Tooltip cases")
+  expect_no_tip(app)
+})