tests-manual/sidebar-bookmarking.R

In rstudio/shinydashboard: Create Dashboards with 'Shiny'

# 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)