added manual tests for bookmarking and the shown/hidden events that h…

…appen on the sidebar

tests-manual/dynamic-sidebar-bookmarking.R

@@ -0,0 +1,120 @@
+# Run this app (with "live" URL bookmarking) to make sure that the sidebar state
+# (collapsed/expanded state of the sidebar itself; selected menuItem and; if
+# applicable, the expanded menuItem)
+
+library(shinydashboard)
+library(shiny)
+library(threejs)
+
+options(shiny.launch.browser=F, shiny.minified=F, shiny.port = 4601)
+
+ui <- function(request) {
+  dashboardPage(
+    dashboardHeader(title = "Testing dynamic sidebar bookmarking"),
+    dashboardSidebar(
+      uiOutput("sidebarControls"),
+      sidebarMenuOutput("menu")
+    ),
+    dashboardBody(
+      tabItems(
+        tabItem("front",
+          h3("Click through the different tabs to see different content")
+        ),
+        tabItem("models1",
+          h3("Here's a linear model"),
+          verbatimTextOutput("models1")
+        ),
+        tabItem("models2",
+          h3("Here's a logistic regression"),
+          verbatimTextOutput("models2")
+        ),
+        tabItem("plots1",
+          h3("Here's a 2D plot"),
+          plotOutput("plots1")
+        ),
+        tabItem("plots2",
+          h3("Here's a 3D plot"),
+          scatterplotThreeOutput('plots2')
+        ),
+        tabItem("tables",
+          h3("Here's a table"),
+          tableOutput("tbl")
+        )
+      )
+    )
+  )
+}
+
+
+server <- function(input, output, session) {
+  output$menu <- renderMenu({
+    sidebarMenu(id = "smenu",
+      menuItem("Frontpage", tabName = "front"),
+      menuItem("Models",
+        menuSubItem("Linear model", "models1"),
+        menuSubItem("Logistic regression", "models2")
+      ),
+      menuItem("Plots",
+        helpText("This is help text"),
+        menuSubItem("Scatterplot", "plots1"),
+        menuSubItem("3D graph", "plots2")
+      ),
+      menuItem("Tables", tabName = "tables")
+    )
+  })
+  output$sidebarControls <- renderUI({
+    req(input$smenu)
+    if (input$smenu %in% c("models1", "models2", "plots1")) {
+      tagList(
+        selectInput("xaxis", "X axis", names(mtcars), selected = input$xaxis),
+        selectInput("yaxis", "Y axis", names(mtcars), selected = input$yaxis)
+      )
+    } else if (input$smenu == "plots2") {
+      tagList(
+        selectInput("xaxis", "X axis", names(mtcars), selected = input$xaxis),
+        selectInput("yaxis", "Y axis", names(mtcars), selected = input$yaxis),
+        selectInput("zaxis", "Z axis", names(mtcars), selected = input$zaxis)
+      )
+    } else NULL
+  })
+
+  formula <- reactive({
+    req(input$yaxis, input$xaxis)
+    as.formula(paste(input$yaxis, input$xaxis, sep = " ~ "))
+  })
+
+  output$models1 <- renderPrint({
+    summary(glm(formula(), data = mtcars), family = "linear")
+  })
+
+  output$models2 <- renderPrint({
+    summary(glm(formula(), data = mtcars), family = "binomial")
+  })
+
+  output$plots1 <- renderPlot({
+    plot(formula(), data = mtcars)
+  })
+
+  output$plots2 <- renderScatterplotThree({
+    x <- mtcars[[input$xaxis]]
+    y <- mtcars[[input$yaxis]]
+    z <- mtcars[[input$zaxis]]
+    scatterplot3js(x, y, z)
+  })
+
+  output$tbl <- renderTable({
+    mtcars
+  })
+
+  observe({
+    reactiveValuesToList(input)
+    session$doBookmark()
+  })
+  onBookmarked(function(url) {
+    updateQueryString(url)
+  })
+
+}
+
+enableBookmarking("url")
+shinyApp(ui, server)

tests-manual/sidebar-bookmarking.R

@@ -0,0 +1,115 @@
+# Run this app (with "live" URL bookmarking) to make sure that the sidebar state
+# (collapsed/expanded state of the sidebar itself; selected menuItem and; if
+# applicable, the expanded menuItem)
+
+library(shinydashboard)
+library(shiny)
+library(threejs)
+
+options(shiny.launch.browser=F, shiny.minified=F, shiny.port = 4601)
+
+ui <- function(request) {
+  dashboardPage(
+    dashboardHeader(title = "Testing sidebar bookmarkability"),
+    dashboardSidebar(
+      uiOutput("sidebarControls"),
+      sidebarMenu(id = "smenu",
+        menuItem(strong("Frontpage"), tabName = "front"),
+        menuItem("Models",
+          menuSubItem("Linear model", "models1"),
+          menuSubItem("Logistic regression", "models2")
+        ),
+        menuItem("Plots",
+          helpText("This is help text"),
+          menuSubItem("Scatterplot", "plots1"),
+          menuSubItem("3D graph", "plots2")
+        ),
+        menuItem("Tables", tabName = "tables")
+      )
+    ),
+    dashboardBody(
+      tabItems(
+        tabItem("front",
+          h3("Click through the different tabs to see different content")
+        ),
+        tabItem("models1",
+          h3("Here's a linear model"),
+          verbatimTextOutput("models1")
+        ),
+        tabItem("models2",
+          h3("Here's a logistic regression"),
+          verbatimTextOutput("models2")
+        ),
+        tabItem("plots1",
+          h3("Here's a 2D plot"),
+          plotOutput("plots1")
+        ),
+        tabItem("plots2",
+          h3("Here's a 3D plot"),
+          scatterplotThreeOutput('plots2')
+        ),
+        tabItem("tables",
+          h3("Here's a table"),
+          tableOutput("tbl")
+        )
+      )
+    )
+  )
+}
+server <- function(input, output, session) {
+  output$sidebarControls <- renderUI({
+    req(input$smenu)
+    if (input$smenu %in% c("models1", "models2", "plots1")) {
+      tagList(
+        selectInput("xaxis", "X axis", names(mtcars), selected = input$xaxis),
+        selectInput("yaxis", "Y axis", names(mtcars), selected = input$yaxis)
+      )
+    } else if (input$smenu == "plots2") {
+      tagList(
+        selectInput("xaxis", "X axis", names(mtcars), selected = input$xaxis),
+        selectInput("yaxis", "Y axis", names(mtcars), selected = input$yaxis),
+        selectInput("zaxis", "Z axis", names(mtcars), selected = input$zaxis)
+      )
+    } else NULL
+  })
+
+  formula <- reactive({
+    req(input$yaxis, input$xaxis)
+    as.formula(paste(input$yaxis, input$xaxis, sep = " ~ "))
+  })
+
+  output$models1 <- renderPrint({
+    summary(glm(formula(), data = mtcars), family = "linear")
+  })
+
+  output$models2 <- renderPrint({
+    summary(glm(formula(), data = mtcars), family = "binomial")
+  })
+
+  output$plots1 <- renderPlot({
+    plot(formula(), data = mtcars)
+  })
+
+  output$plots2 <- renderScatterplotThree({
+    x <- mtcars[[input$xaxis]]
+    y <- mtcars[[input$yaxis]]
+    z <- mtcars[[input$zaxis]]
+    scatterplot3js(x, y, z)
+  })
+
+  output$tbl <- renderTable({
+    mtcars
+  })
+
+  observe({
+    reactiveValuesToList(input)
+    session$doBookmark()
+  })
+  onBookmarked(function(url) {
+    updateQueryString(url)
+  })
+
+}
+
+enableBookmarking("url")
+shinyApp(ui, server)

tests-manual/trigger-shown-sidebar.R

@@ -0,0 +1,39 @@
+# Run this app to test that Shiny outputs that are initally hidden inside
+# menuItems become visible ( trigger("shown) ) after we expand the respective
+# menuItem.
+
+library(shiny)
+library(shinydashboard)
+
+options(shiny.launch.browser=F, shiny.minified=F, shiny.port = 9000)
+
+ui <- function(req) {
+  dashboardPage(
+    dashboardHeader(),
+    dashboardSidebar(
+      sidebarMenu(id = "smenu",
+        menuItem("Menu Item 1", tabName = "tab1", "text1", menuSubItem("name", tabName = "tabName")),
+        menuItem("Menu Item 2", tabName = "tab2", textOutput("text2"), startExpanded = FALSE,
+          expandedName = "expanded")
+      )
+    ),
+    dashboardBody(
+      tabItems(tabItem("tabName", h3("This is the only content")))
+    )
+  )
+}
+
+server <- function(input, output, session) {
+  output$text2 <- renderText("text2")
+
+  observe({
+    reactiveValuesToList(input)
+    session$doBookmark()
+  })
+  onBookmarked(function(url) {
+    updateQueryString(url)
+  })
+}
+
+enableBookmarking("url")
+shinyApp(ui = ui, server = server)