Starting Shiny App After Password Input

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)

Sample Image

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

Example of front page

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

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)

How to require user authentication in R Shiny before users see any part of the app using shinyauthr?

Update:

Though I can't find an answers using shinyauthr and sodium, I have found a way to accomplish my goal with shinymanger and scyrpt.

The code below is modified from the first answer on this post, and it includes an encrypted password. To access the app, the password is "ice" without the quotations. The username is "1", again without the quotations.

The important part is, within credentials, to set the is_hashed_password argument to TRUE. The hashing it recognizes is scrypt's method, not sodium.

I'll keep this question open for a few more days in case someone can figure out the answer to my original question. Otherwise, I'll consider this equivalent solution as acceptable:

library(shiny)
library(shinymanager)
library(scrypt)

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();"

password <- "c2NyeXB0ABAAAAAIAAAAAVYhtzTyvRJ9e3hYVOOk63KUzmu7rdoycf3MDQ2jKLDQUkpCpweMU3xCvI3C6suJbKss4jrNBxaEdT/fBzxJitY3vGABhpPahksMpNu/Jou5"

# data.frame with credentials info
credentials <- data.frame(
  user = c("1", "fanny", "victor", "benoit"),
  password = password,
  is_hashed_password = TRUE,
  # 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)

Create one shiny app with two users that log in to different versions of the app

One possible way of doing this with shinymanager is as below. Another self build solution can be found here with more explanation on github.

The quote regarding self-build authentication in shiny in the comments is of course correct: using an approach outside of shiny is the better way.

# define some credentials
credentials <- data.frame(
  user = c("shiny", "shinymanager"), # mandatory
  password = c("azerty", "12345"), # mandatory
  start = c("2019-04-15"), # optinal (all others)
  expire = c(NA, NA),
  admin = c(FALSE, TRUE),
  comment = "Simple and secure authentification mechanism
  for single ‘Shiny’ applications.",
  stringsAsFactors = FALSE
)

library(shiny)
library(shinymanager)

ui <- fluidPage(
  tags$h2("My secure application"),
  uiOutput("myinput"),
  tableOutput("data")
)

# Wrap your UI with secure_app
ui <- secure_app(ui)


server <- function(input, output, session) {
  
  # call the server part
  # check_credentials returns a function to authenticate users
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )

  output$myinput <- renderUI({

    if (reactiveValuesToList(res_auth)$user == "shiny") {
    # if (TRUE) {
      mychoices <- c("Cylinders" = "cyl",
                     "Transmission" = "am",
                     "Gears" = "gear")
    } else {
      mychoices <- c("Sepal Length" = "Sepal.Length",
                     "Sepal Width" = "Sepal.Width",
                     "Petal Length" = "Petal.Length",
                     "Petal Width" = "Petal.Width")
    }

    selectInput("variable",
                "Variable:",
                choices = mychoices)
  })
  
  output$data <- renderTable({
    
    expr = if (reactiveValuesToList(res_auth)$user == "shiny") {
      mtcars[, c("mpg", input$variable), drop = FALSE]
    } else {
      iris[, c("Species", input$variable), drop = FALSE]
    }
    })

}

shinyApp(ui, server)

Run a app from terminal and send a password

I don't know about your security necessity in your use case...

What you could'd do (if its ok for you to specify a password while calling Rscript), is giving the password as an extra parameter when calling RScript and then forwarding it to ssh_connect(). You could also do the same with host variable. Im calling this R file via:

Rscript --vanilla home/user/R/app.R "password"

I'm not running shiny::runApp, because the line shinyApp(ui=ui, server=server) will automatically start up the shiny application, allowing us to connect to ssh beforehand.

In the app.R file we forward the arguments to ssh_connect.

app.R

library(shiny)
library(ssh)
args <- commandArgs(trailingOnly = TRUE)
host="host"
ssh.session <- ssh::ssh_connect(host = host,passwd = )
cat("*** Logging in of the session ***")

# Define UI for application that draws a histogram
ui <- fluidPage()

server <- function(input, output) {

  onStop(function() {
    ssh_disconnect(ssh.session)
    cat("*** Logging out of the session ***")
  })
}

# Run the application
shinyApp(ui = ui, server = server)

Shiny App: Adding unlimited number of input bars

We can try this approach:

We can access new added inputs with input$a1, input$a2 ... input$ax

Edit: added an observer to see the new inputs generated in the console. The first input created after pressing + button will be called input$a1.

  observe({
    print(names(input))
    print(input$a1)
  })
library(shiny)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectizeInput("a", "Something", choices = "blah blah"),
      actionButton(inputId = "rm", label = "-"),
      actionButton(inputId = "add", label = "+"),
    ),
    mainPanel(
      textOutput("test")
    )
  )
)


server <- function(input, output) {
  input_counter <- reactiveVal(0)

  observeEvent(input$add, {
    input_counter(input_counter() + 1)
    insertUI(
      selector = "#rm", where = "beforeBegin",
      ui = div(id = paste0("selectize_div", input_counter()), selectizeInput(paste0("a", input_counter()), label = "Another thing", choices = c("bla", "blabla")))
    )
  })
  observeEvent(input$rm, {
    removeUI(
      selector = paste0("#selectize_div", input_counter())
    )
    input_counter(input_counter() - 1)
  })

  observe({
    print(names(input))
    print(input$a1)
  })
}



shinyApp(ui, server)

Related Topics

Using Data.Table Package Inside My Own Package

Pass Arguments to Dplyr Functions

Suppress Nas in Paste()

Conditional Merge/Replacement in R

Test If Characters Are in a String

Pass Column Name in Data.Table Using Variable

How to Subtract/Add Days From/To a Date

Adding Minor Tick Marks to the X Axis in Ggplot2 (With No Labels)

Case_When in Mutate Pipe

Replace All Particular Values in a Data Frame

Repeat Rows of a Data.Frame

How to Replace Na With Mean by Group/Subset

Select Groups Which Have At Least One of a Certain Value

Idiomatic R Code For Partitioning a Vector by an Index and Performing an Operation on That Partition

How to Handle R Cmd Check "No Visible Binding For Global Variable" Notes When My Ggplot2 Syntax Is Sensible

Control Ggplot2 Legend Look Without Affecting the Plot

Dplyr: How to Use Group_By Inside a Function

Data.Table "Key Indices" or "Group Counter"


Leave a reply



Submit