A Shiny app combining the use of dplyr and SQLite. The goal is to demonstrate a full-fledged, database-backed user authorization framework in Shiny.

server.R

library(shiny)
library(dplyr)
library(lubridate)

# Load libraries and functions needed to create SQLite databases.
library(RSQLite)
library(RSQLite.extfuns)
saveSQLite <- function(data, name){
  path <- dplyr:::db_location(filename=paste0(name, ".sqlite"))
  if (!file.exists(path)) {
    message("Caching db at ", path)
    src <- src_sqlite(path, create = TRUE)
    copy_to(src, data, name, temporary = FALSE)
  } else {
    src <- src_sqlite(path)
  }
  return (src)
}

# Load/create some data and put it in SQLite. In practice, the data you want
# likely already exists in the databse, so you would just be reading the data
# in from the database, not uploading it from R.

# Load and upload flights data
library(hflights)
hflights_db <- tbl(hflights_sqlite(), "hflights")

# Create a user membership data.frame that maps user names to an airline 
# company.
membership <- data.frame(
  user = c("kim", "sam", "john", "kelly", "ben", "joe"),
  company = c("", "DL", "AA", "UA", "US", "DL"),
  role = c("manager", rep("user", 5)))
membership_db <- tbl(saveSQLite(membership, "membership"), "membership")

airlines <- data.frame(
  abbrev = c("AA", "DL", "UA", "US"),
  name = c("American Airlines", "Delta Air Lines", 
           "United Airlines", "US Airways")
)
airline_db <- tbl(saveSQLite(airlines, "airline"), "airline")


#' Get the full name of an airline given its abbreviation.
airlineName <- function(abbr){
  as.data.frame(select(filter(airline_db, abbrev == abbr), name))[1,1]
}

shinyServer(function(input, output, session) {
  
  #' Get the current user's username
  user <- reactive({
    
    curUser <- session$user
    
    # Not logged in. Shiny Server Pro should be configured to prevent this.
    if (is.null(curUser)){
      return(NULL)
    }
    
    # Look up the user in the database to load all the associated data.
    user <- as.data.frame(
      filter(membership_db, user==curUser)      
    )
    
    # No user in the database
    if (nrow(user) < 1){
      return(NULL)
    }
    
    user[1,]    
  })
  
  #' Determine whether or not the current user is a manager.
  isManager <- reactive({
    if (is.null(user())){
      return(FALSE)
    }
    
    role <- user()$role
    return(role == "manager")    
  })
  
  #' Get the company of which the current user is a member
  userCompany <- reactive({
    if (is.null(user())){
      return(NULL)
    }
    
    if (isManager()){
      # If the user is a manager, then they're allowed to select any company
      # they want and view its data.
      if (is.null(input$company)){
        return(as.data.frame(airline_db)$abbrev[1])
      }
      return(input$company)
    }
    
    # Otherwise this is just a regular, logged-in user. Look up what company
    # they're associated with and return that.
    user()$company
  })
  
  #' Get the data the current user has permissions to see
  #' @return a dplyr tbl
  companyData <- reactive({
    # Trim down to only relevant variables
    delays <- select(hflights_db, Month, DayofMonth, DepDelay, UniqueCarrier)
    
    # Trim down to only values that we have permissions to see
    comp <- userCompany()
    delays <- filter(delays, UniqueCarrier == comp)
    
    delays
  })
  
  #' Of the data a user is allowed to see, further refine it to only include the
  #' date range selected by the user.
  filteredData <- reactive({
    # Get current month and day
    curMonth <- month(now())
    curDay <- day(now())

    # Get the previous month and day based on the slider input
    prevMonth <- month(now()-days(input$days))
    prevDay <- day(now()-days(input$days))
    
    # Filter to only include the flights in between the selected dates.
    data <- filter(companyData(), 
           (Month > prevMonth | (Month == prevMonth & DayofMonth >= prevDay)) &
           (Month < curMonth | (Month == curMonth & DayofMonth <= curDay)))
    
    as.data.frame(data)
  })
  
  output$title <- renderText({
    if(is.null(user())){
      return("ERROR: This application is designed to be run in Shiny Server Pro and to require authentication.")
    }
    paste0("Airline Delays for ", airlineName(userCompany()))
  })
  
  output$userPanel <- renderUI({
    if (isManager()){
      # The management UI should have a drop-down that allows you to select a 
      # company.
      tagList(
        HTML(paste0("Logged in as <code>", user()$user, 
                    "</code> who is a <code>", user()$role ,"</code>.")),
        hr(),
        p("As a manager, you may select any company's data you wish to view."),
        selectInput("company", "", as.data.frame(airline_db)$abbrev)
      )
    } else{
      # It's just a regular user. Just tell them who they are.
      HTML(paste0("Logged in as <code>", user()$user, "</code> with <code>",
                  airlineName(userCompany()),"</code>."))
    }
  })
  
  #' Print a boxplot of the selected data.
  output$box <- renderPlot({    
    boxplot(
      lapply(
        split(filteredData(), as.factor(
          paste0(filteredData()$Month, "/", filteredData()$DayofMonth))), 
        function(dayData){ 
          dayData$DepDelay 
        }
      ), ylab = "Delay (minutes)"
    )
  })
   
})

ui.R

library(shiny)

shinyUI(
  fluidPage(
    # Setup the page title
    tagList(tags$head(tags$title("Airline Delays")), h1(textOutput("title"))),    
    
    sidebarLayout(
      sidebarPanel(
        uiOutput("userPanel"),
        hr(),
        sliderInput("days", "Prior days to include:", 1, 30, 7, 1),
        hr(),        
        helpText("The graph on the right shows a boxplot of the departure " ,
                 "delays for the airline(s) your username is allowed to view.")
      ),
      mainPanel(
        plotOutput("box")
      )
    )
  )
)

RSQLite.extfuns’ was removed from the CRAN repository. Archived on 2014-10-29 as it does not work with RSQLite 1.0.0, which subsumes it.

Does the above code, then, requires than an older (prior to 1.0.0) version of RSQLite and the archived RSQLite.extfuns, or would it be possible for you to update the code?

Cheers

BUMP

Where is the login form at the beginning of the example? How the two components (login form and app) are linked together?
I am trying to deploy a simpler but effective auth system on Shiny Server Open following many of the discussions around, however it would be good to have a look at that.

I have a same question with GroundworkGIS. Where is the login form at the beginning of the example? did not find it in the code.

Try "install.packages("RMySQL", dependencies=TRUE)".

Hope it will solve.....

@trestletech Where is the user auth code? Its a shame this code does not replicate the entire example on the shiny gallery

could you have the member list and passwords backed up to a database like mongolite?

A shame this code doesn't work anymore. I request an update :)

Hi trestletech,

Thank you for creating such a great example. Unfortunately, it does not seem to work anymore.
Is there going to be an update to this?

I needed the user authentication part, so stripped out all code related to SQL. Even after doing that, the app reports: "ERROR: This application is designed to be run in Shiny Server Pro and to require authentication." So, you won't be able to use this example for user authentication unless you already have Shiny Server Pro.

I am doing a project on R shiny which require authentication.As I don't have Shiny server pro,so I have used like this

1> Creating a table on Local system SQL database with loginID & password field..
then the following code in Server.r

library(RODBC)
channel <- odbcConnect("joy_test_sql_data_source", uid="shiny_test", pwd="shiny123")

login_table<<-as.data.frame(sqlQuery(channel,"select * FROM [R_shiny_test].[dbo].[login_id]"))

observeEvent(input$login,{
  
  uid_t<-isolate(input$uid)
  pwd_t<-isolate(input$password)
  if(input$uid=="")
  {
    showModal(modalDialog(
      title = "Invalid",
      "Please Fill Username"
    ))
  }
  else if(input$password=="")
  {
    showModal(modalDialog(
      title = "Invalid",
      "Please Fill Password"
    ))
  }
  else if(input$uid=="" &&input$password=="" )
  {
    showModal(modalDialog(
      title = "Invalid",
      "Please Fill Username & Password"
    )) 
  }
  else if(ui_t %in% login_table$username==TRUE|pwd_t %in% login_table$password==TRUE)
  {
    temp_login<-login_table[(login_table$username == uid_t ), ]
    if(temp_login$username==input$uid && temp_login$password==input$password)
    {
      library(tcltk)
      tkmessageBox(title = "XyBot",message = "Login Sucessful", icon = "info", type = "ok")
      shinyjs::removeClass(selector = "body", class = "sidebar-collapse")
      updateTabsetPanel(session, "tabs",selected ="data_upload")
      user_logged<-1
      shinyjs::disable("login_box")

    }
    else
    {
      tkmessageBox(title = "XyBot",message = "Wrong Credentials", icon = "info", type = "ok")
    }
  }
  else 
  {
    showModal(modalDialog(
      title = "Wrong",
      "Please Check your Credentials "
    ))
  }
    
})

So is it right to do it?? without R Shiny Server pro is there any other method?

@subhasish1315 as long as you keep passwords as hashed in database and compare hashed passwords this is a valid implementation. For security purposes, you shouldn't store any plain user password.

Package RSQLite.extfuns is no longer on CRAN. Is anyone else able to run this particular app?

You can install removed packages from the CRAN archives: https://cran.r-project.org/src/contrib/Archive/RSQLite.extfuns/

usually I am encrypting passwords that are used in Shiny to connect with Databases. It can be done using package openssl or in case more people are working on that using package secret

Is this a working example? I run into errors every time? Is there any updated version. Thank you

@trestletech Could you, please, say where can get working code?

i've seen a recent working example at https://github.com/paulc91/shinyauthr maybe it could suffice the same requirement

https://github.com/paulc91/shinyauthr is good for me,thanks!