Add 313-card-tab-focus

R/data-apps-deps.R

@@ -60,4 +60,5 @@ apps_deps_map <- list(`001-hello` = "rsconnect", `012-datatables` = "ggplot2",
     "rversions"), `305-bslib-value-box` = c("rlang", "rversions"
     ), `309-flexdashboard-tabs-navs` = "rmarkdown", `310-bslib-sidebar-dynamic` = c("rversions", 
     "testthat"), `311-bslib-sidebar-toggle-methods` = c("rversions", 
-    "testthat"))
+    "testthat"), `313-bslib-card-tab-focus` = c("rversions", 
+    "testthat", "withr"))

inst/apps/311-bslib-sidebar-toggle-methods/app.R

@@ -17,59 +17,57 @@ animals <- c(
   "otter", "panda", "panther", "penguin", "zebra"
 )
 
-sb <- layout_column_wrap(
-  width = 500,
-  id = "sidebar-here",
-  layout_sidebar(
-    id = "main_outer",
-    sidebar = sidebar(
-      "Outer Sidebar",
-      id = "sidebar_outer",
-      width = 150,
-      bg = color_pairs[[1]]$dark,
-      open = "desktop",
-      max_height_mobile = "300px",
-      selectInput(
-        "adjective",
-        "Adjective",
-        choices = adjectives,
-        selected = adjectives[1]
-      )
-    ),
-    height = 300,
-    class = "p-0",
-    fillable = TRUE,
+ui <- page_fixed(
+  h1("Dynamic Sidebars"),
+  tags$head(tags$title("bslib | Tests | Dynamic Sidebars")),
+  p(
+    "Test tab focus order: main, inner sidebar, outer sidebar.",
+    "Test server-side open and close of sidebars."
+  ),
+  layout_column_wrap(
+    width = 500,
+    id = "sidebar-here",
     layout_sidebar(
-      id = "main_inner",
+      id = "main_outer",
       sidebar = sidebar(
-        "Inner Sidebar",
-        id = "sidebar_inner",
+        "Outer Sidebar",
+        id = "sidebar_outer",
         width = 150,
-        bg = color_pairs[[1]]$light,
+        bg = color_pairs[[1]]$dark,
         open = "desktop",
+        max_height_mobile = "300px",
         selectInput(
-          "animal",
-          "Animal",
-          choices = animals,
-          selected = animals[1]
+          "adjective",
+          "Adjective",
+          choices = adjectives,
+          selected = adjectives[1]
         )
       ),
-      border = FALSE,
-      border_radius = FALSE,
-      h2("Sidebar Layout"),
-      uiOutput("ui_content", tabindex = 0)
+      height = 300,
+      class = "p-0",
+      fillable = TRUE,
+      layout_sidebar(
+        id = "main_inner",
+        sidebar = sidebar(
+          "Inner Sidebar",
+          id = "sidebar_inner",
+          width = 150,
+          bg = color_pairs[[1]]$light,
+          open = "desktop",
+          selectInput(
+            "animal",
+            "Animal",
+            choices = animals,
+            selected = animals[1]
+          )
+        ),
+        border = FALSE,
+        border_radius = FALSE,
+        h2("Sidebar Layout"),
+        uiOutput("ui_content", tabindex = 0),
+      )
     )
-  )
-)
-
-ui <- page_fixed(
-  h1("Dynamic Sidebars"),
-  tags$head(tags$title("bslib | Tests | Dynamic Sidebars")),
-  p(
-    "Test tab focus order: main, inner sidebar, outer sidebar.",
-    "Test server-side open and close of sidebars."
   ),
-  tagAppendAttributes(sb, class = "mb-4", id = "layout"),
   div(
     class = "my-2",
     actionButton("show_all", "Show all"),

inst/apps/311-bslib-sidebar-toggle-methods/tests/testthat/test-shinytest2.R

@@ -12,58 +12,7 @@ is_mac_release <- identical(paste0("mac-", release), platform_variant())
 
 DO_SCREENSHOT <- is_testing_on_ci && is_mac_release
 
-key_press_factory <- function(app) {
-  brwsr <- app$get_chromote_session()
-
-  function(which = "Tab", shift = FALSE) {
-    virtual_code <- switch(
-      which,
-      Tab = 9,
-      Enter = 13,
-      Escape = 27,
-      ArrowLeft = 37,
-      ArrowUp = 38,
-      ArrowRight = 39,
-      ArrowDown = 40,
-      Backspace = 8,
-      Delete = 46,
-      Home = 36,
-      End = 35,
-      PageUp = 33,
-      PageDown = 34,
-      Space = 32
-    )
-
-    modifiers <- 0
-    if (shift) modifiers <- modifiers + 8
-    # if (command) modifiers <- modifiers + 4
-    # if (control) modifiers <- modifiers + 2
-    # if (alt) modifiers <- modifiers + 1
-
-    events <-
-      brwsr$Input$dispatchKeyEvent(
-        "rawKeyDown",
-        windowsVirtualKeyCode = virtual_code,
-        code = which,
-        key = which,
-        modifiers = modifiers,
-        wait_ = FALSE
-      )$then(
-        brwsr$Input$dispatchKeyEvent(
-          "keyUp",
-          windowsVirtualKeyCode = virtual_code,
-          code = which,
-          key = which,
-          modifiers = modifiers,
-          wait_ = FALSE
-        )
-      )
-
-    brwsr$wait_for(events)
-
-    invisible(app)
-  }
-}
+source(system.file("helpers", "keyboard.R", package = "shinycoreci"))
 
 expect_sidebar_hidden_factory <- function(app) {
   function(which = c("inner", "outer")) {

inst/apps/313-bslib-card-tab-focus/README.md

@@ -0,0 +1,3 @@
+## 313-bslib-card-tab-focus
+
+`313-bslib-card-tab-focus` tests the tab focus order of full screen cards.

inst/apps/313-bslib-card-tab-focus/app.R

@@ -0,0 +1,65 @@
+library(shiny)
+library(bslib)
+
+ui <- page_fixed(
+  h1("Dynamic Sidebars"),
+  tags$head(tags$title("bslib | Tests | Dynamic Sidebars")),
+  div(id = "neutral-focus-zone", tabindex = "-1"),
+  layout_column_wrap(
+    width = 1 / 2,
+    card(
+      id = "card-no-inputs",
+      full_screen = TRUE,
+      card_header("Nothing to focus on here"),
+      shiny::p(
+        "This is a boring card with just some plain text.",
+        "There's something to read here but there aren't any inputs to focus on.",
+        "Tabbing will only move focus to the \"Close\" button."
+      )
+    ),
+    card(
+      id = "card-with-inputs",
+      full_screen = TRUE,
+      card_header("Inputs, oh my!"),
+      shiny::p(
+        "Here's a bit of text! This card does have stuff to focus on, and the",
+        "first focusable element is automatically focused when the card is expanded.",
+        "Try tabbing through the inputs, you can't leave!"
+      ),
+      layout_column_wrap(
+        width = "200px",
+        class = "mb-3",
+        card(
+          id = "card-with-inputs-left",
+          full_screen = TRUE,
+          card_title("Left Column", class = "mb-3"),
+          shiny::selectInput("letter", "Letter", letters, selected = "a"),
+          shiny::selectizeInput("letter2", "Letter 2", letters, selected = "b", multiple = TRUE),
+          shiny::dateRangeInput("dates", "Pick a Date")
+        ),
+        card(
+          id = "card-with-inputs-right",
+          full_screen = TRUE,
+          card_title("Right Column", class = "mb-3"),
+          shiny::sliderInput("slider", "Pick a Number", min = 1, max = 10, value = 5),
+          shiny::textInput("word", "Word", "hello"),
+          shiny::textAreaInput("sentence", "Sentence", "hello world")
+        )
+      ),
+      shiny::actionButton("go", "Go")
+    ),
+    card(
+      id = "card-with-plot",
+      full_screen = TRUE,
+      card_header("A plotly plot"),
+      textInput("search", "Search", "search or something"),
+      plotly::plot_ly(x = rnorm(1e4), y = rnorm(1e4))
+    )
+  )
+)
+
+server <- function(input, output, session) {
+  # no server logic
+}
+
+shinyApp(ui, server)

inst/apps/313-bslib-card-tab-focus/tests/testthat.R

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

inst/apps/313-bslib-card-tab-focus/tests/testthat/setup-shinytest2.R

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