Starting Shiny App After Password Input (With Shinydashboard)

Starting Shiny app after password input (with Shinydashboard)

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)

Starting Shiny app after password input

EDIT 2019: We can now use the package shinymanager to do this: the invactivity script is to timeout the login page after 2 mins of inactivity so you dont waste resources:

library(shiny)
library(shinymanager)

inactivity <- "function idleTimer() {
var t = setTimeout(logout, 120000);
window.onmousemove = resetTimer; // catches mouse movements
window.onmousedown = resetTimer; // catches mouse movements
window.onclick = resetTimer;     // catches mouse clicks
window.onscroll = resetTimer;    // catches scrolling
window.onkeypress = resetTimer;  //catches keyboard actions

function logout() {
window.close();  //close the window
}

function resetTimer() {
clearTimeout(t);
t = setTimeout(logout, 120000);  // time is in milliseconds (1000 is 1 second)
}
}
idleTimer();"


# data.frame with credentials info
credentials <- data.frame(
  user = c("1", "fanny", "victor", "benoit"),
  password = c("1", "azerty", "12345", "azerty"),
  # comment = c("alsace", "auvergne", "bretagne"), %>% 
  stringsAsFactors = FALSE
)

ui <- secure_app(head_auth = tags$script(inactivity),
                 fluidPage(
                   # classic app
                   headerPanel('Iris k-means clustering'),
                   sidebarPanel(
                     selectInput('xcol', 'X Variable', names(iris)),
                     selectInput('ycol', 'Y Variable', names(iris),
                                 selected=names(iris)[[2]]),
                     numericInput('clusters', 'Cluster count', 3,
                                  min = 1, max = 9)
                   ),
                   mainPanel(
                     plotOutput('plot1'),
                     verbatimTextOutput("res_auth")
                   )
                   
                 ))

server <- function(input, output, session) {
  
  result_auth <- secure_server(check_credentials = check_credentials(credentials))
  
  output$res_auth <- renderPrint({
    reactiveValuesToList(result_auth)
  })
  
  # classic app
  selectedData <- reactive({
    iris[, c(input$xcol, input$ycol)]
  })
  
  clusters <- reactive({
    kmeans(selectedData(), input$clusters)
  })
  
  output$plot1 <- renderPlot({
    palette(c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3",
              "#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999"))
    
    par(mar = c(5.1, 4.1, 0, 1))
    plot(selectedData(),
         col = clusters()$cluster,
         pch = 20, cex = 3)
    points(clusters()$centers, pch = 4, cex = 4, lwd = 4)
  })
  
}


shinyApp(ui = ui, server = server)

Original Post:
I am going to answer #1 and for #2 you can simply expand on my example. Following this example Encrypt password with md5 for Shiny-app. you can do the following:

1. Create 2 pages and if the user inputs the correct username and password you can renderUI and use htmlOutput to output your page
2. You can style the position of the box with username and password with tagsas I did and color them if you want also using tags$style

You can then further look into the actual page and specify what should be created as a result of different users. You can also look into JavaScript Popup Boxes

EDIT 2018: Also have a look at the example here https://shiny.rstudio.com/gallery/authentication-and-database.html

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(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
    }
  })
})

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

How to stop html widget from moving to the bottom of the shiny app following input

The CSS selector of the container for the widget was set to body rather than of the element.

---

Related Topics