Skip to content

Instantly share code, notes, and snippets.

@trestletech
Last active February 2, 2022 09:47
Show Gist options
  • Star 99 You must be signed in to star a gist
  • Fork 55 You must be signed in to fork a gist
  • Save trestletech/9793754 to your computer and use it in GitHub Desktop.
Save trestletech/9793754 to your computer and use it in GitHub Desktop.
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")
)
)
)
)
@ddaskan
Copy link

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.

Copy link

ghost commented Jun 24, 2017

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

@KasperSkytte
Copy link

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

@vzhomeexperiments
Copy link

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
Copy link

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

@mishaborys
Copy link

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

Copy link

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
Copy link

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