Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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.
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)"
)
})
})
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")
)
)
)
)
@lalas

This comment has been minimized.

Copy link

@lalas lalas commented Oct 21, 2015

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

@subhashjaini

This comment has been minimized.

Copy link

@subhashjaini subhashjaini commented Apr 12, 2016

BUMP

@GroundworkGIS

This comment has been minimized.

Copy link

@GroundworkGIS GroundworkGIS commented Jun 4, 2016

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.

@notgoodatall

This comment has been minimized.

Copy link

@notgoodatall notgoodatall commented Sep 6, 2016

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.

@udkumar

This comment has been minimized.

Copy link

@udkumar udkumar commented Sep 12, 2016

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

Hope it will solve.....

@AugustT

This comment has been minimized.

Copy link

@AugustT AugustT commented Nov 10, 2016

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

@ghost

This comment has been minimized.

Copy link

@ghost ghost commented Dec 14, 2016

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

@KasperSkytte

This comment has been minimized.

Copy link

@KasperSkytte KasperSkytte commented Jan 2, 2017

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

@mudsahni

This comment has been minimized.

Copy link

@mudsahni mudsahni commented Jan 4, 2017

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?

@alexperrone

This comment has been minimized.

Copy link

@alexperrone alexperrone commented Apr 4, 2017

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.

@subhasish1315

This comment has been minimized.

Copy link

@subhasish1315 subhasish1315 commented May 3, 2017

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?

@ddaskan

This comment has been minimized.

Copy link

@ddaskan ddaskan commented May 4, 2017

@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.

@ghost

This comment has been minimized.

Copy link

@ghost ghost commented Jun 24, 2017

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

@KasperSkytte

This comment has been minimized.

Copy link

@KasperSkytte KasperSkytte commented Sep 20, 2017

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

@vzhomeexperiments

This comment has been minimized.

Copy link

@vzhomeexperiments vzhomeexperiments commented Jan 20, 2018

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

@gadepallivs

This comment has been minimized.

Copy link

@gadepallivs gadepallivs commented Feb 21, 2018

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

@mishaborys

This comment has been minimized.

Copy link

@mishaborys mishaborys commented Mar 15, 2018

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

@ghost

This comment has been minimized.

Copy link

@ghost ghost commented Nov 15, 2018

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

@wikithink

This comment has been minimized.

Copy link

@wikithink wikithink commented May 16, 2019

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment