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

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!