Add unit tests for bslib::popover() (#203)

Co-authored-by: cpsievert <[email protected]>

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"
+    ))

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

@@ -131,4 +131,3 @@ server <- function(input, output, session) {
 }
 
 shinyApp(ui, server)
-

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)

inst/apps/316-bslib-popovers/tests/testthat.R

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

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()
+