输入密码后启动 Shiny 应用程序（使用 Shinydashboard）

Question

In this topic is well explained how to start the shinyapp after some password input. I am trying to do the same, but instead of "navbarPage", I would like to have a "dashboardPage".

I tried to change the argument in do.call function form 'navbarPage' to 'dashboardPage', but the app crashes.

rm(list = ls())
library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test"))}

ui = (htmlOutput("page"))
server = (function(input, output,session) {

  USER <- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {

      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(dashboardPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
    }
  })
})

runApp(list(ui = ui, server = server))

Answer 1

I woder if my code is enough to get you started on the "right" path. Please let me know if it is not the case.

The code below, if the login and password are correct, will display a shinydashboard.

but the following issues will need addressing:

• There is a problem in the css. I think you need to "reset" the css changed for the login operation to something more standard to shinydashboard (currently it is all white)
• If the password is wrong, the first observe will keep on "winning" on the renderUI (with or without a second observe , strictly speaking unnecessary hence eliminated) and the message relative to the wrong login is never executed.

There are number of things you could try to fix the above.

• For the css you could either re-set it, or elegantly have the login in a modal.
• For the second perhaps you could bring all the logic into the renderUI call. This would make sure that all cases are executed.

But please let me know if it is clear enough.

This is the code:

rm(list = ls())
library(shiny)
library(shinydashboard)

Logged = FALSE

my_username <- "test"
my_password <- "test"

ui1 <- function() {
  tagList(
    div(
      id = "login",
      wellPanel(
        textInput("userName", "Username"),
        passwordInput("passwd", "Password"),
        br(),
        actionButton("Login", "Log in")
      )
    ),
    tags$style(
      type = "text/css",
      "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}"
    )
  )
}

ui2 <- function() {
  tagList(dashboardHeader(),
          dashboardSidebar(),
          dashboardBody("Test"))
}


ui = (htmlOutput("page"))

server = function(input, output, session) {
  USER <- reactiveValues(Logged = Logged)

  observe({
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (length(input$Login) > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 &
              length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            }
          }
        }
      }
    }
  })

  output$page <- renderUI({
    if (USER$Logged == FALSE) {
      do.call(bootstrapPage, c("", ui1()))
    } else {
      do.call(dashboardPage, #c(inverse=TRUE,title = "Contratulations you got in!",
              ui2())
    }
  })
}

shinyApp(ui, server)

October 30, 2017 Update

It seems that the above code doesn't work anymore (thanks to @5249203 for pointing this out).

I've tried to fix it, but I haven't managed to make the do.call function work with dashboardBody (if somebody knows of a way, please let me know!).

Therefore I approached the problem in another way, thanks to recent shiny functions.

See what you think (of course as usual the solution is just a template needing extensions).

library(shiny)
library(shinydashboard)

Logged = FALSE
my_username <- "test"
my_password <- "test"

ui <- dashboardPage(skin='blue',
  dashboardHeader( title = "Dashboard"),
  dashboardSidebar(),
  dashboardBody("Test",
    # actionButton("show", "Login"),
  verbatimTextOutput("dataInfo")
    )
)

server = function(input, output,session) {

values <- reactiveValues(authenticated = FALSE)

# Return the UI for a modal dialog with data selection input. If 'failed' 
# is TRUE, then display a message that the previous value was invalid.
dataModal <- function(failed = FALSE) {
  modalDialog(
    textInput("username", "Username:"),
    passwordInput("password", "Password:"),
    footer = tagList(
      # modalButton("Cancel"),
      actionButton("ok", "OK")
    )
  )
}

# Show modal when button is clicked.  
# This `observe` is suspended only whith right user credential

obs1 <- observe({
  showModal(dataModal())
})

# When OK button is pressed, attempt to authenticate. If successful,
# remove the modal. 

obs2 <- observe({
  req(input$ok)
  isolate({
    Username <- input$username
    Password <- input$password
  })
  Id.username <- which(my_username == Username)
  Id.password <- which(my_password == Password)
  if (length(Id.username) > 0 & length(Id.password) > 0) {
    if (Id.username == Id.password) {
      Logged <<- TRUE
        values$authenticated <- TRUE
        obs1$suspend()
        removeModal()

    } else {
      values$authenticated <- FALSE
    }     
  }
  })


output$dataInfo <- renderPrint({
  if (values$authenticated) "OK!!!!!"
  else "You are NOT authenticated"
})

}

shinyApp(ui,server)

Answer 2

Here is another solution that takes a slightly different approach than @Enzo's. It creates a second UI so users cannot see what the app is displaying on the first menu tab. The only downside is everything is basically brought to the Server side which may cause some issues for your code depending on how it is written.

library(shiny)
library(shinydashboard)

my_username <- "test"
my_password <- "abc"

###########################/ui.R/##################################

header <- dashboardHeader(title = "my heading")
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"))
body <- dashboardBody(uiOutput("body") )

ui <- dashboardPage(header, sidebar, body)

###########################/server.R/##################################

server <- function(input, output, session) {
  Logged <- FALSE

  USER <<- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <<- TRUE
            } 
          }
        } 
      }
    }    
  })

  output$sidebarpanel <- renderUI({
    if (USER$Logged == TRUE) { 
      dashboardSidebar(
        sidebarUserPanel("myuser", subtitle = a(icon("user"), "Logout", href="")),
        selectInput("in_var", "myvar", multiple = FALSE,
                    choices = c("option 1","option 2")),
        sidebarMenu(
          menuItem("Item 1", tabName = "t_item1", icon = icon("line-chart")),
          menuItem("Item 2", tabName = "t_item2", icon = icon("dollar")),
          menuItem("Item 3", tabName = "t_item3", icon = icon("credit-card")),
          menuItem("Item 4", tabName = "t_item4", icon = icon("share-alt"))
        ))}
  })

  output$body <- renderUI({
    if (USER$Logged == TRUE) {
      B <- c(2,3,4,3,7,5,4)

      box(
        title = p("Histogram", actionLink("Expand", "", icon = icon("expand"))), status = "primary", solidHeader = TRUE, width = 4,
        hist(B)
      )
    }
    if (USER$Logged == FALSE) {
      box(title = "Login",textInput("userName", "Username"),
          passwordInput("passwd", "Password"),
          br(),
          actionButton("Login", "Log in"))
    }
  })
}

shinyApp(ui, server)

September 2018 Update

I was able to figure out @Enzo's original code to make the do.call function work with shinydashboard . Please see below. Credit to @Enzo for this, I just slightly changed some lines. I think this solution is better than my first code above since it allows the correct output codes to stay in the UI side. I've also added a message pop-up if the username and password is incorrect.

rm(list = ls())
library(shiny)
library(shinydashboard)

my_username <- "test"
my_password <- "abc"

###########################/ui.R/##################################

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),
                  actionButton("Login", "Log in"),
                  verbatimTextOutput("dataInfo")
        )
    ),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(
  "You did it!"
)}

header <- dashboardHeader(title = "Test Login")
sidebar <- dashboardSidebar()
body <- dashboardBody(
  tags$head(tags$style("#dataInfo{color: red")),
  htmlOutput("page")
)

ui <- dashboardPage(header, sidebar, body)

###########################/server.R/##################################

server = (function(input, output,session) {

  Logged <- FALSE
  Security <- TRUE

  USER <- reactiveValues(Logged = Logged)
  SEC <- reactiveValues(Security = Security)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          if(my_username == Username & my_password == Password) {
            USER$Logged <- TRUE
          } else {SEC$Security <- FALSE}
        } 
      }
    }    
  })

  observe({
    if (USER$Logged == FALSE) {output$page <- renderUI({ui1()})}
    if (USER$Logged == TRUE) {output$page <- renderUI({ui2()})}
  })

  observe({
    output$dataInfo <- renderText({
      if (SEC$Security) {""}
      else {"Your username or password is not correct"}
    })
  })

})

runApp(list(ui = ui, server = server))

Answer 3

Your example uses a single user. I made some modifications for multiple user/password situations. This seems to work for me. Hopefully, others may find it helpful:

library(shiny)
library(shinydashboard)
library(tidyverse)

user_base <- tibble(
  user =     c("Test1", "Test2", "Test3"),
  password = c("abc", "bcd", "cde"),
  name =     c("User1", "User2", "User3")
)

###########################/ui.R/##################################

header <- dashboardHeader(title = "my heading")
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"))
body <- dashboardBody(uiOutput("body") )
ui <- dashboardPage(header, sidebar, body)

###########################/server.R/##################################

server <- function(input, output, session) {
  Logged <- FALSE

  USER <<- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(user_base$user == Username)
          Id.password <- which(user_base$password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <<- TRUE
            } 
          }
        } 
      }
    }    
  })

  output$sidebarpanel <- renderUI({
    if (USER$Logged == TRUE) { 
      dashboardSidebar(
        sidebarUserPanel("myuser", subtitle = a(icon("user"), "Logout", href="")),
        selectInput("in_var", "myvar", multiple = FALSE,
                    choices = c("option 1","option 2")),
        sidebarMenu(
          menuItem("Item 1", tabName = "t_item1", icon = icon("line-chart")),
          menuItem("Item 2", tabName = "t_item2", icon = icon("dollar")),
          menuItem("Item 3", tabName = "t_item3", icon = icon("credit-card")),
          menuItem("Item 4", tabName = "t_item4", icon = icon("share-alt"))
        ))}
  })

  output$body <- renderUI({
    if (USER$Logged == TRUE) {
      B <- c(2,3,4,3,7,5,4)

      box(
        title = p("Histogram", actionLink("Expand", "", icon = icon("expand"))), 
        status = "primary", solidHeader = TRUE, width = 4,
        hist(B)
      )
    }
    if (USER$Logged == FALSE) {
      box(title = "Login",textInput("userName", "Username"),
          passwordInput("passwd", "Password"),
          br(),
          actionButton("Login", "Log in"))
    }
  })
}

shinyApp(ui, server)