diff --git a/R/data-apps-deps.R b/R/data-apps-deps.R index f8134843e9..e5e2f191f3 100644 --- a/R/data-apps-deps.R +++ b/R/data-apps-deps.R @@ -64,4 +64,6 @@ apps_deps_map <- list(`001-hello` = "rsconnect", `012-datatables` = "ggplot2", `310-bslib-sidebar-dynamic` = c("rversions", "testthat"), `311-bslib-sidebar-toggle-methods` = c("rversions", "testthat" ), `313-bslib-card-tab-focus` = c("rversions", "testthat", - "withr"), `314-bslib-tooltips` = "withr", `315-bslib-input-switch` = "withr") + "withr"), `314-bslib-tooltips` = "withr", `315-bslib-input-switch` = "withr", + `316-bslib-popovers` = c("rversions", "testthat", "withr" + )) diff --git a/inst/apps/314-bslib-tooltips/app.R b/inst/apps/314-bslib-tooltips/app.R index 1447aaa833..389b6ec6dd 100644 --- a/inst/apps/314-bslib-tooltips/app.R +++ b/inst/apps/314-bslib-tooltips/app.R @@ -131,4 +131,3 @@ server <- function(input, output, session) { } shinyApp(ui, server) - diff --git a/inst/apps/316-bslib-popovers/app.R b/inst/apps/316-bslib-popovers/app.R new file mode 100644 index 0000000000..1074c836e3 --- /dev/null +++ b/inst/apps/316-bslib-popovers/app.R @@ -0,0 +1,143 @@ +library(shiny) +library(bslib) +library(plotly) + +ui <- page_navbar( + title = "Popover tests", + fillable = FALSE, + id = "navbar", + theme = bs_theme("enable-transitions" = interactive()), + + nav_panel( + "Popover cases", + inputPanel( + class = "px-3 py-5", + h3("Triggers"), + popover( + id = "pop-hello", + "Hello popover", + "Hello popover" + ), + popover( + id = "pop-inline", + span("Inline popover"), + "Inline popover" + ), + popover( + id = "pop-hyperlink", + a("Hyperlink popover", href = "https://github.com"), + "Hyperlink popover" + ), + popover( + id = "pop-action-link", + actionLink("btn_link", "actionLink()"), + "actionLink() message" + ), + popover( + id = "pop-action", + actionButton("btn", "A button"), + "Popover 1" + ), + popover( + id = "pop-multiple", + tagList( + actionButton("btn2", "A button"), + actionButton("btn3", "A button"), + ), + "A popover" + ) + ), + inputPanel( + class = "px-3 py-5", + h3("Options"), + popover( + span("Offset (50,50)", id = "pop-offset"), + "This tip should appear 50px down/right", + placement = "right", + options = list(offset = c(50, 50)) + ), + popover( + span("No animation", id = "pop-animation"), + "This tip shouldn't fade in/out", + placement = "right", + options = list(animation = FALSE) + ) + ) + ), + nav_panel( + "Popover updates", + layout_sidebar( + card( + card_header( + popover( + span( + "Card title with popover", + bsicons::bs_icon("question-circle-fill") + ), + "Popover message", + id = "popover", + placement = "right" + ) + ), + plotlyOutput("bars") + ), + sidebar = list( + textInput("popover_msg", "Enter a popover message", "Popover message"), + actionButton("show_popover", "Show popover", class = "mb-3"), + actionButton("hide_popover", "Hide popover"), + br(), + input_switch("show_title", "Add a popover title"), + conditionalPanel( + "input.show_title", + textInput("popover_title", "Enter a title", "Popover title"), + ) + ) + ) + ), + + nav_panel( + "Popover inputs", + uiOutput("num_out"), + popover( + id = "btn_pop", + actionButton("btn4", "Show popover"), + "Change the number", + numericInput("num", NULL, 1), + selectInput("sel", "Select", state.name), + title = "Input controls" + ), + actionLink("inc", "Increment number") + ) + +) + +server <- function(input, output, session) { + observe({ + update_popover( + "popover", input$popover_msg, + title = if (input$show_title) input$popover_title + ) + }) + + observeEvent(input$show_popover, { + toggle_popover("popover", show = TRUE) + }) + + observeEvent(input$hide_popover, { + toggle_popover("popover", show = FALSE) + }) + + output$bars <- renderPlotly({ + plot_ly(diamonds, x = ~cut) + }) + + output$num_out <- renderPrint({ + input$num + }) + + observeEvent(input$inc, { + updateNumericInput(inputId = "num", value = input$num + 1) + }) +} + +shinyApp(ui, server) diff --git a/inst/apps/316-bslib-popovers/tests/testthat.R b/inst/apps/316-bslib-popovers/tests/testthat.R new file mode 100644 index 0000000000..7d25b5b9e4 --- /dev/null +++ b/inst/apps/316-bslib-popovers/tests/testthat.R @@ -0,0 +1 @@ +shinytest2::test_app() diff --git a/inst/apps/316-bslib-popovers/tests/testthat/setup-shinytest2.R b/inst/apps/316-bslib-popovers/tests/testthat/setup-shinytest2.R new file mode 100644 index 0000000000..e739c4dd99 --- /dev/null +++ b/inst/apps/316-bslib-popovers/tests/testthat/setup-shinytest2.R @@ -0,0 +1,3 @@ +# Load application support files into testing environment +shinytest2::load_app_env() + diff --git a/inst/apps/316-bslib-popovers/tests/testthat/test-316-bslib-popovers.R b/inst/apps/316-bslib-popovers/tests/testthat/test-316-bslib-popovers.R new file mode 100644 index 0000000000..9b3f537234 --- /dev/null +++ b/inst/apps/316-bslib-popovers/tests/testthat/test-316-bslib-popovers.R @@ -0,0 +1,262 @@ +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 + ) + app$wait_for_js(js) + invisible(app) +} + +# Setup App -------------------------------------------------- +app <- AppDriver$new( + name = "316-bslib-popovers", + variant = platform_variant(), + height = 800, + width = 1200, + seed = 20230724, + view = interactive(), + options = list(bslib.precompiled = FALSE), + expect_values_screenshot_args = FALSE, + screenshot_args = list(selector = "viewport", delay = 0.5) +) +withr::defer(app$stop()) + + +# Setup App state and utility functions ------------------------ + +# Before focusing any tooltips, set up an event handler to keep +# track of the last tooltip shown +app$run_js( + '$(document).on("shown.bs.popover", function(e) { window.lastShown = e.target; });' +) + +key_press <- key_press_factory(app) + +# 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;" + ) +} + +expect_no_tip <- function() { + app$wait_for_js("$('.popover:visible').length === 0;") +} + +click_close_button <- function() { + app$click(selector = ".popover .btn-close") +} + +expect_popover_content <- function(app, body = NULL, header = NULL) { + body_js <- sprintf( + "document.querySelector('.popover-body').innerText === '%s'", + body + ) + header_js <- sprintf( + "document.querySelector('.popover-header').innerText === '%s'", + header + ) + if (!is.null(body)) app$wait_for_js(body_js) + if (!is.null(header)) app$wait_for_js(header_js) +} + + +# Tests for the 1st tab (Popover cases) +test_that("Can tab focus various cases/options", { + expect_focus(app, "body") + + key_press("Tab") + expect_focus(app, ".nav-link.active") + + # Triggers ---------------------------------- + # These aren't tags, so Tab+Enter (or click) + # should show the popover + key_press("Tab") + key_press("Enter") + expect_focus(app, "#pop-hello span") + expect_visible_tip(app, "#pop-hello span") + key_press("Enter") + expect_no_tip() + expect_focus(app, "#pop-hello span") + + # Make sure the popover is focusable via keyboard + key_press("Enter") + expect_focus(app, "#pop-hello span") + expect_visible_tip(app, "#pop-hello span") + key_press("Tab") + expect_focus(app, ".popover") + key_press("Tab") + # At this point, focus should be on the close button, but we can't explictly + # check for that since document.activeElement is empty for some reason, which + # is really odd because if you $view() the app it's clearly focused and + # document.activeElement isn't empty. We can implictly check for this though + # by making sure we can Tab+Shift back to the trigger. + key_press("Tab", shift = TRUE) + key_press("Tab", shift = TRUE) + expect_focus(app, "#pop-hello span") + expect_visible_tip(app, "#pop-hello span") + + click_close_button() + expect_focus(app, "#pop-hello span") + expect_no_tip() + + key_press("Enter") + expect_focus(app, "#pop-hello span") + expect_visible_tip(app, "#pop-hello span") + key_press("Escape") + expect_focus(app, "#pop-hello span") + expect_no_tip() + key_press("Enter") + expect_focus(app, "#pop-hello span") + expect_visible_tip(app, "#pop-hello span") + key_press("Tab") + key_press("Tab") + key_press("Escape") + expect_focus(app, "#pop-hello span") + expect_no_tip() + + key_press("Tab") + key_press("Enter") + expect_focus(app, "#pop-inline span") + expect_visible_tip(app, "#pop-inline span") + key_press("Enter") + expect_no_tip() + + key_press("Tab") + expect_focus(app, "#pop-hyperlink a") + expect_visible_tip(app, "#pop-hyperlink a") + + key_press("Tab") + expect_no_tip() + key_press("Enter") + expect_focus(app, "#btn_link") + expect_visible_tip(app, "#btn_link") + key_press("Enter") + expect_no_tip() + expect_true(app$get_value(input = "btn_link") == 2) + + # For some odd reason it seems a key_press("Enter") on a