paulc91 / shinyauthr Goto Github PK
View Code? Open in Web Editor NEWR package with shiny authentication modules
Home Page: https://paulc91.github.io/shinyauthr/
License: Other
R package with shiny authentication modules
Home Page: https://paulc91.github.io/shinyauthr/
License: Other
I tried to use shinyauthr in flexdashboard app, use the demo code just work in in one column of dashboard. normally login and logout.
However the login module it dost not hide the content of the dashboard. I know they are not in one ui element.
But in flexdashboard, element were splited in different cols, do it possible use shinyauthr to control the whole app.
I have built an app using the following example as a template as it uses shinydashboard and hides content until a user has logged in.
https://github.com/PaulC91/shinyauthr/blob/master/inst/shiny-examples/shinyauthr_example/app.R
I am having trouble showing a loading icon/spinner while plots are build built. For example, using the shinycssloaders package with the 'withSpinner()' function. This should be added as follows: plotOutput("myplot") %>% withSpinner().
However as I am using the uiOutput("testUI") function and renderUI() within the server, its unclear where the withSpinner() function should be added. Ive tried all the options i can think of without any luck. It appears work for the whole page if i add it to the uiOutput("testUI) %>% withSpinner(), but the page is just blank while the plot is loading.
I cant install the Package "shinyauthr" using the below line
remotes::install_github("paulc91/shinyauthr")
I got the following Error:
Downloading GitHub repo paulc91/shinyauthr@master
Error in utils::download.file(url, path, method = method, quiet = quiet, :
cannot open URL 'https://api.github.com/repos/paulc91/shinyauthr/tarball/master'
Any advice,
Amr
Hello,
I'm trying to implement the return key that triggers the connect button in a Shiny app. I saw what you did using some js here (https://gist.github.com/PaulC91/bd5035875305dfad504f1a3794233186).
So I tried to connect both methods but unsuccessfully ...
Here is the jQuery code I used :
$(document).keyup(function(event) {
if ($("#id").is(":focus") && (event.keyCode == 13)) {
$("#button").click();
}
});
I think that as the id is namepaces in the loginUI, this method won't work.
Any idea ? :)
Thank you in advance,
Marouane
Hi Paul,
Would it be possible to answer this question
Basically I would like to display my sidebar panel to user 1 and MainPanel table to user 2.
Below is my code:
#Storing data on Local Machine
library(shiny)
library(ggplot2)
outputDir <- "responses"
# Define the fields we want to save from the form
fields <- c("name", "address","used_shiny", "r_num_years","select")
#Which fields are mandatory
fieldsMandatory<-c("name","address")
labelMandatory <- function(label) {
tagList(
label,
span("*", class = "mandatory_star")
)
}
appCSS <-
".mandatory_star { color: red; }
#error { color: red; }"
saveData <- function(input) {
# put variables in a data frame
data <- data.frame(matrix(nrow=1,ncol=0))
for (x in fields) {
var <- input[[x]]
if (length(var) > 1 ) {
# handles lists from checkboxGroup and multiple Select
data[[x]] <- list(var)
} else {
# all other data types
data[[x]] <- var
}
}
data$submit_time <- date()
# Create a unique file name
fileName <- sprintf(
"%s_%s.rds",
as.integer(Sys.time()),
digest::digest(data)
)
# Write the file to the local system
saveRDS(
object = data,
file = file.path(outputDir, fileName)
)
}
loadData <- function() {
# read all the files into a list
files <- list.files(outputDir, full.names = TRUE)
if (length(files) == 0) {
# create empty data frame with correct columns
field_list <- c(fields, "submit_time")
data <- data.frame(matrix(ncol = length(field_list), nrow = 0))
names(data) <- field_list
} else {
data <- lapply(files, function(x) readRDS(x))
# Concatenate all data together into one data.frame
data <- do.call(rbind, data)
}
data
}
deleteData <- function() {
# Read all the files into a list
files <- list.files(outputDir, full.names = TRUE)
lapply(files, file.remove)
}
resetForm <- function(session) {
# reset values
updateTextInput(session, "name", value = "")
updateTextInput(session, "address", value = "")
updateCheckboxInput(session, "used_shiny", value = FALSE)
updateSliderInput(session, "r_num_years", value = 0)
updateSelectInput(session,"select",selected = 'NULL')
}
ui <- fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
# App title ----
titlePanel("Data Collection & Feedback"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
div(id='form',
textInput("name", labelMandatory("Name"), ""),
textInput("address",labelMandatory('address'),""),
checkboxInput("used_shiny", "I've built a Shiny app before", FALSE),
sliderInput("r_num_years", "Number of years using R",
0, 10, 0, ticks = FALSE),
selectInput("select","select",choices = c('a','e','i')),
actionButton("submit", "Submit",class='btn-primary'),
actionButton("clear", "Clear Form"),
downloadButton("downloadData", "Download"),
actionButton("delete", "Delete All Data"),
shinyjs::hidden(
span(id = "submit_msg", "Submitting..."),
div(id = "error",
div(br(), tags$b("Error: "), span(id = "error_msg"))
)
)
),
shinyjs::hidden(
div(
id = "thankyou_msg",
h3("Thanks, your response was submitted successfully!"),
actionLink("submit_another", "Submit another response")
)
)
),
# Main panel for displaying outputs ----
mainPanel(
dataTableOutput("responses")
)
)
)
server = function(input, output, session) {
# Enable the Submit button when all mandatory fields are filled out
observe({
mandatoryFilled <-
vapply(fieldsMandatory,
function(x) {
!is.null(input[[x]]) && input[[x]] != ""
},
logical(1))
mandatoryFilled <- all(mandatoryFilled)
shinyjs::toggleState(id = "submit", condition = mandatoryFilled)
})
# When the Submit button is clicked, save the form data
observeEvent(input$submit, {
#saveData(input)
#resetForm(session)
shinyjs::disable("submit")
shinyjs::show("submit_msg")
shinyjs::hide("error")
tryCatch({
saveData(input)
shinyjs::reset("form")
shinyjs::hide("form")
shinyjs::show("thankyou_msg")
},
error = function(err) {
shinyjs::html("error_msg", err$message)
shinyjs::show(id = "error", anim = TRUE, animType = "fade")
},
finally = {
shinyjs::enable("submit")
shinyjs::hide("submit_msg")
})
})
observeEvent(input$submit_another, {
shinyjs::show("form")
shinyjs::hide("thankyou_msg")
})
observeEvent(input$clear, {
resetForm(session)
})
# When the Delete button is clicked, delete all of the saved data files
observeEvent(input$delete, {
deleteData()
})
# Show the previous responses in a reactive table ----
output$responses <- renderDataTable({
# update with current response when Submit or Delete are clicked
input$submit
input$delete
loadData()
})
# Downloadable csv of selected dataset ----
output$downloadData <- downloadHandler(
filename= "data.csv",
content = function(file) {
write.csv(loadData(), file, row.names = FALSE, quote= TRUE)
}
)
}
shinyApp(ui, server)
Thanks in advance,
Where should I put the data for my own app? And I find that through the sidebar, the user can access the data directly and it doesn't block it.
`library(shinydashboard)
library(dplyr)
library(shinycssloaders)
library(shinyWidgets)
library(shinyauthr)
library(shinyjs)
cookie_expiry <- 7
user_base <- data.frame(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
permissions = c("admin", "standard"),
name = c("User One", "User Two"),
stringsAsFactors = FALSE
)
get_sessions_from_db <- function(conn = db, expiry = cookie_expiry) {
dbReadTable(conn, "sessions") %>%
mutate(login_time = ymd_hms(login_time)) %>%
as_tibble() %>%
filter(login_time > now() - days(expiry))
}
add_session_to_db <- function(user, sessionid, conn = db) {
tibble(user = user, sessionid = sessionid, login_time = as.character(now())) %>%
dbWriteTable(conn, "sessions", ., append = TRUE)
}
db <- dbConnect(SQLite(), ":memory:")
dbCreateTable(db, "sessions", c(user = "TEXT", sessionid = "TEXT", login_time = "TEXT"))
user_base <- tibble(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
password_hash = sapply(c("pass1", "pass2"), sodium::password_store),
permissions = c("admin", "standard"),
name = c("User One", "User Two")
)
ui <- dashboardPage(
dashboardHeader(
title = "abc",
tags$li(
class = "dropdown",
style = "padding: 8px;",
shinyauthr::logoutUI("logout")
),
dropdownMenu(
type = "messages",
badgeStatus = NULL,
messageItem("Feedback and suggestions",
"qwe",
href = "qwe")
)
),
dashboardSidebar(
collapsed = TRUE,
div(textOutput("welcome"), style = "padding: 20px"),
searchInput(
inputId = "gene",
label = "abcd",
placeholder = "Potential Gene",
value = "abcd",
btnSearch = icon("search"),
width = "100%"
),
sidebarMenu(
menuItem(
"Potential function of the gene",
tabName = "page1",
icon = icon("compass")
),
menuItem(
"Tips for 123 figures",
tabName = "page2",
icon = icon("list")
),
menuItem(
"Gene for adult sample",
tabName = "page3",
icon = icon("lightbulb")
)
)
),
dashboardBody(
shinyauthr::loginUI(
"login",
cookie_expiry = cookie_expiry,
additional_ui = tagList(
tags$p("test the different outputs from the sample logins below
as well as an invalid login attempt.", class = "text-center"),
HTML(knitr::kable(user_base[, -3], format = "html", table.attr = "style='width:100%;'"))
)
),
tabItems(
tabItem(tabName = "page1",
fluidRow(
valueBoxOutput("Potential_Score"),
valueBoxOutput("Multi_species"),
valueBoxOutput("Multi_omics"),
column(
width = 12,class = "text-center",
box(status = "primary",
plotOutput("123", width = "380px", height = "360px") %>% withSpinner(color = "#EA2027"),
title = "123",
width = 4
),
box(status = "warning",
plotOutput("456", width = "400px", height = "360px") %>% withSpinner(color = "#EE5A24"),
title = "456",
width = 4
),
box(status = "success",
plotOutput("789", width = "350px", height = "360px") %>% withSpinner(color = "#F79F1F"),
title = "789",
width = 4
),
))
)
))
)
`
Any advice would be greatly appreciated!
How would I go about using Shinyauthr with UI elements such as navbarPage, navbarMenu, and tabPanel.
ui <- shinyUI(
navbarPage("A Nice Title",
navbarMenu("A Menu",
tabPanel("With",
tabPanel("Tabs"))))
placing the shinyauthr::loginUI between any of these shiny pages, menus, and panels results in nonfunctional outputs.
I've also tried storing the ui in a renderUI function, but the navbarPage does not appear. Is Shinyauthr able to work with these shiny elements, is there a possible workaround?
Thank you for great package!
Are there any tricks for using Shinyauth with Flexdashboard instead of pure Shiny and/or Shinydashboard?
I have tried with no success.
Hi and thanks for the great package!
Is it possible to log (or to limit) password failures with shinyauthr? I only figure out to log successful log-ins.
Thanks :)
AFAICT, logoutUI
simply wraps arround shiny::actionButton
but does not allow to pass an icon to that button. I think this could be resolved by simply adding ...
to the argument list.
I could provide a PR if there is interest.
Hello,
I'm wondering if its possible to change the background and text colour for the login UI.
I tried using the additional_ui parmeter with div(style = "background-color: lightblue;"), but that didn't seem to work.
Thanks!
The newest version.
Each user would lose their login information once refreshed the page.
Hey,
First of all: Thanks for the great package.
I found out that you can't log in, if the passwort contains the character §. Don't know if there are other characters which will cause that bug also, I didn't find out.
Minimal example:
Just run your example app with:
user_base <- data.frame(user = "test", password = "§test")
It will always say "Invalid username or password!"
Also if § isn't the first character, it will cause this bug.
how to customize the shinyauthr loginUI??
The live example app linked in the README returns a 404 for me.
Hi,
I am using the package and it works just perfect, thank you a lot.
Is there an option to add some extra HTML under the login menu?
Something like: if you forgot your password please contact us at [email protected]
To be just under or somewhere on this screen.
Thank you
Hi Paul,
I am trying to configure your logout.R to add a pop-out window. What I want to achieve is to transfer current log-out button to a modal button and then logout by activating an actionbutton added to modalDialog. But what I got is a pop-out window when log-in.
Could you tell me which part I should change? I must added to the wrong location.
Thanks a lot.
Using standard hasing algorithms from digest
for passwords is not secure (anymore). You are vulnerable to a number of attacks, in particular to brute-force attacks.
I would suggest using a dedicated password hashing algorithm like scrypt, bcrypt, argon2 etc. More on this here: https://download.libsodium.org/doc/password_hashing/
The function deriving a key from a password and a salt is CPU intensive and
intentionally requires a fair amount of memory. Therefore, it mitigates
brute-force attacks by requiring a significant effort to verify each password.
The sodium package implements something very nice:
sodium::password_store(password = "wat")
#> [1] "$7$C6..../....HHM5gAOk/6vdFKYFjG0a6MXPtKkljccJax.tfl5mJL4$5m0cYitpFUdswBbOEL51Jd8L5AtodOOu0FonRzn0UlA"
sodium::password_verify(sodium::password_store(password = "wat"), "wat")
#> [1] TRUE
Thank you for your package, it saves a lot!
I want to use user_info()$permissions == "..."
to control the appearance of certain tabPanel()
in fluidPage()
. It works when first login, but after logout, the re-login process requires to refresh the web-page, other wise the web-page just not render the uiOutput("2")
and uiOutput("3")
, as well as the glue()
in sidebar.
Do you have any idea why this happens?
ui <- dashboardPage(header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = dashboardBody(
shinyjs::useShinyjs(),
tags$head(tags$style(".table{margin: 0 auto;}"),
tags$script(src="https://cdnjs.cloudflare.com/ajax/libs/iframe-resizer/3.5.16/iframeResizer.contentWindow.min.js",
type="text/javascript"),
includeScript("returnClick.js")
),
shinyauthr::loginUI("login"),
uiOutput("prelogin"), # same as uiOutput("user_table") in your example
uiOutput("afterlogin"), # here i encountered issue
HTML('<div data-iframe-height></div>')
))
server <- function(input, output, session) {
output$afterlogin <- renderUI({
afterloginUI()
})
## issue may related to here
afterloginUI <- reactive({
req(credentials()$user_auth)
if (user_info()$permissions == "standard") {
fluidPage(
tabsetPanel(type = "tabs",
tabPanel("1", uiOutput("1")),
tabPanel("2", uiOutput("2"))
)
)
} else if (user_info()$permissions == "admin") {
fluidPage(
tabsetPanel(type = "tabs",
tabPanel("1", uiOutput("1")),
tabPanel("2", uiOutput("2")),
tabPanel("3", uiOutput("3"))
)
)
}
})
}
Note: for uiOutput("2")
and uiOutput("3")
, there are calls in their server like observe({})
and observeEvent({})
, this is the major difference between uiOutput("1")
.
Thanks in advance!
First off, would like to thank you for putting all the work in this package. It has made my life simpler.
However, there is always room for improvement and one problem I noticed that I have to re-login in every new window because currently the package doesn't store successful authentication persistently across tabs so want propose a feature : Would anyone be up for collaboration to combine cookie.js to save session-id per user as Cookie with a custom expiry period such that the same user is not required to login again in that time period.
This blog uses this cookie.js and exemplifies its usage in R.
Hello.
First of all I would like to thank you for this great clearance package.
In general it works quite well for both login and logout but sometimes I encounter problems when the shiny session gives timeout after a long time.
When you refresh the page with F5 it freezes and on the terminal where the application is running I get these messages.
Warning: Error in UseMethod: no applicable method for 'tbl_vars' applied to an object of class "list"
69: tbl_vars_dispatch
66: tbl_vars
64: tbl_nongroup_vars
63: tbl_if_vars
59: tbl_if_syms
58: manip_if
57: dplyr::mutate_if
56: shinyauthr::loginServer
51: server
5: shiny::runApp
4: eval
3: eval
1: source
Error in UseMethod("tbl_vars") :
no applicable method for 'tbl_vars' applied to an object of class "list"
I realise that it is not at all easy to reproduce this error, but perhaps with this information you can guess what might be happening and how to avoid it.
This is the information of the package I have installed, as shown in the R statement sessionInfo()$otherPkgs$shinyauthr
Package: shinyauthr
Type: Package
Title: 'Shiny' Authentication Modules
Version: 1.0.0
Authors@R: c(person(given = "Paul", family = "Campbell", email = "[email protected]", role = c("aut", "cre"), comment =
c(ORCID = "0000-0003-1018-6606")), person(given = "Michael", family = "Dewar", email = "[email protected]",
role = "ctb"))
Description: Add in-app user authentication to 'shiny', allowing you to secure publicly hosted apps and build dynamic user
interfaces from user information.
License: MIT + file LICENSE
Encoding: UTF-8
Imports: shiny (>= 1.5.0), shinyjs, dplyr, rlang, sodium, glue
Suggests: DBI, RSQLite, lubridate, shinydashboard, testthat (>= 3.0.0), shinytest, knitr, rmarkdown, covr
RoxygenNote: 7.1.1
URL: https://github.com/paulc91/shinyauthr
BugReports: https://github.com/paulc91/shinyauthr/issues
Config/testthat/edition: 3
NeedsCompilation: no
Packaged: 2021-07-19 10:41:29 UTC; paul
Author: Paul Campbell [aut, cre] (<https://orcid.org/0000-0003-1018-6606>), Michael Dewar [ctb]
Maintainer: Paul Campbell <[email protected]>
Repository: CRAN
Date/Publication: 2021-07-20 07:20:02 UTC
Built: R 4.1.2; ; 2022-06-12 10:08:22 UTC; unix
Thank you very much in advance
Is it possible to use shinyauthr
inside a shiny app like superzip? I tried the following:
library(leaflet)
library(shinyauthr)
library(shinyjs)
# Choices for drop-downs
vars <- c(
"Is SuperZIP?" = "superzip",
"Centile score" = "centile",
"College education" = "college",
"Median income" = "income",
"Population" = "adultpop"
)
fluidPage(
# must turn shinyjs on
shinyjs::useShinyjs(),
# add logout button UI
div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
# add login panel UI function
shinyauthr::loginUI(id = "login"),
# setup table output to show user info after login
uiOutput("superzip")
)
library(leaflet)
library(RColorBrewer)
library(scales)
library(lattice)
library(dplyr)
user_base <- data.frame(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
permissions = c("admin", "standard"),
name = c("User One", "User Two"),
stringsAsFactors = FALSE,
row.names = NULL
)
# Leaflet bindings are a bit slow; for now we'll just sample to compensate
set.seed(100)
zipdata <- allzips[sample.int(nrow(allzips), 10000),]
# By ordering by centile, we ensure that the (comparatively rare) SuperZIPs
# will be drawn last and thus be easier to see
zipdata <- zipdata[order(zipdata$centile),]
function(input, output, session) {
# call the logout module with reactive trigger to hide/show
logout_init <- callModule(shinyauthr::logout,
id = "logout",
active = reactive(credentials()$user_auth))
# call login module supplying data frame, user and password cols
# and reactive trigger
credentials <- callModule(shinyauthr::login,
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
log_out = reactive(logout_init()))
# pulls out the user information returned from login module
user_data <- reactive({credentials()$info})
## Interactive Map ###########################################
# Create the map
output$map <- renderLeaflet({
leaflet() %>%
addTiles(
urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
attribution = 'Maps by <a href="http://www.mapbox.com/">Mapbox</a>'
) %>%
setView(lng = -93.85, lat = 37.45, zoom = 4)
})
# A reactive expression that returns the set of zips that are
# in bounds right now
zipsInBounds <- reactive({
if (is.null(input$map_bounds))
return(zipdata[FALSE,])
bounds <- input$map_bounds
latRng <- range(bounds$north, bounds$south)
lngRng <- range(bounds$east, bounds$west)
subset(zipdata,
latitude >= latRng[1] & latitude <= latRng[2] &
longitude >= lngRng[1] & longitude <= lngRng[2])
})
# Precalculate the breaks we'll need for the two histograms
centileBreaks <- hist(plot = FALSE, allzips$centile, breaks = 20)$breaks
output$histCentile <- renderPlot({
# If no zipcodes are in view, don't plot
if (nrow(zipsInBounds()) == 0)
return(NULL)
hist(zipsInBounds()$centile,
breaks = centileBreaks,
main = "SuperZIP score (visible zips)",
xlab = "Percentile",
xlim = range(allzips$centile),
col = '#00DD00',
border = 'white')
})
output$scatterCollegeIncome <- renderPlot({
# If no zipcodes are in view, don't plot
if (nrow(zipsInBounds()) == 0)
return(NULL)
print(xyplot(income ~ college, data = zipsInBounds(), xlim = range(allzips$college), ylim = range(allzips$income)))
})
# This observer is responsible for maintaining the circles and legend,
# according to the variables the user has chosen to map to color and size.
observe({
# use req to only render results when credentials()$user_auth is TRUE
req(credentials()$user_auth)
#
colorBy <- input$color
sizeBy <- input$size
if (colorBy == "superzip") {
# Color and palette are treated specially in the "superzip" case, because
# the values are categorical instead of continuous.
colorData <- ifelse(zipdata$centile >= (100 - input$threshold), "yes", "no")
pal <- colorFactor("viridis", colorData)
} else {
colorData <- zipdata[[colorBy]]
pal <- colorBin("viridis", colorData, 7, pretty = FALSE)
}
if (sizeBy == "superzip") {
# Radius is treated specially in the "superzip" case.
radius <- ifelse(zipdata$centile >= (100 - input$threshold), 30000, 3000)
} else {
radius <- zipdata[[sizeBy]] / max(zipdata[[sizeBy]]) * 30000
}
leafletProxy("map", data = zipdata) %>%
clearShapes() %>%
addCircles(~longitude, ~latitude, radius=radius, layerId=~zipcode,
stroke=FALSE, fillOpacity=0.4, fillColor=pal(colorData)) %>%
addLegend("bottomleft", pal=pal, values=colorData, title=colorBy,
layerId="colorLegend")
})
# Show a popup at the given location
showZipcodePopup <- function(zipcode, lat, lng) {
selectedZip <- allzips[allzips$zipcode == zipcode,]
content <- as.character(tagList(
tags$h4("Score:", as.integer(selectedZip$centile)),
tags$strong(HTML(sprintf("%s, %s %s",
selectedZip$city.x, selectedZip$state.x, selectedZip$zipcode
))), tags$br(),
sprintf("Median household income: %s", dollar(selectedZip$income * 1000)), tags$br(),
sprintf("Percent of adults with BA: %s%%", as.integer(selectedZip$college)), tags$br(),
sprintf("Adult population: %s", selectedZip$adultpop)
))
leafletProxy("map") %>% addPopups(lng, lat, content, layerId = zipcode)
}
# When map is clicked, show a popup with city info
observe({
leafletProxy("map") %>% clearPopups()
event <- input$map_shape_click
if (is.null(event))
return()
isolate({
showZipcodePopup(event$id, event$lat, event$lng)
})
})
## Data Explorer ###########################################
observe({
cities <- if (is.null(input$states)) character(0) else {
filter(cleantable, State %in% input$states) %>%
`$`('City') %>%
unique() %>%
sort()
}
stillSelected <- isolate(input$cities[input$cities %in% cities])
updateSelectInput(session, "cities", choices = cities,
selected = stillSelected)
})
observe({
zipcodes <- if (is.null(input$states)) character(0) else {
cleantable %>%
filter(State %in% input$states,
is.null(input$cities) | City %in% input$cities) %>%
`$`('Zipcode') %>%
unique() %>%
sort()
}
stillSelected <- isolate(input$zipcodes[input$zipcodes %in% zipcodes])
updateSelectInput(session, "zipcodes", choices = zipcodes,
selected = stillSelected)
})
observe({
if (is.null(input$goto))
return()
isolate({
map <- leafletProxy("map")
map %>% clearPopups()
dist <- 0.5
zip <- input$goto$zip
lat <- input$goto$lat
lng <- input$goto$lng
showZipcodePopup(zip, lat, lng)
map %>% fitBounds(lng - dist, lat - dist, lng + dist, lat + dist)
})
})
output$ziptable <- DT::renderDataTable({
df <- cleantable %>%
filter(
Score >= input$minScore,
Score <= input$maxScore,
is.null(input$states) | State %in% input$states,
is.null(input$cities) | City %in% input$cities,
is.null(input$zipcodes) | Zipcode %in% input$zipcodes
) %>%
mutate(Action = paste('<a class="go-map" href="" data-lat="', Lat, '" data-long="', Long, '" data-zip="', Zipcode, '"><i class="fa fa-crosshairs"></i></a>', sep=""))
action <- DT::dataTableAjax(session, df)
DT::datatable(df, options = list(ajax = list(url = action)), escape = FALSE)
})
output$superzip <- renderUI({
# use req to only render results when credentials()$user_auth is TRUE
req(credentials()$user_auth)
## The old superzip ui
navbarPage("Superzip", id="nav",
tabPanel("Interactive map",
div(class="outer",
tags$head(
# Include our custom CSS
includeCSS("styles.css"),
includeScript("gomap.js")
),
# If not using custom CSS, set height of leafletOutput to a number instead of percent
leafletOutput("map", width="100%", height="100%"),
# Shiny versions prior to 0.11 should use class = "modal" instead.
absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
draggable = TRUE, top = 60, left = "auto", right = 20, bottom = "auto",
width = 330, height = "auto",
h2("ZIP explorer"),
selectInput("color", "Color", vars),
selectInput("size", "Size", vars, selected = "adultpop"),
conditionalPanel("input.color == 'superzip' || input.size == 'superzip'",
# Only prompt for threshold when coloring or sizing by superzip
numericInput("threshold", "SuperZIP threshold (top n percentile)", 5)
),
plotOutput("histCentile", height = 200),
plotOutput("scatterCollegeIncome", height = 250)
),
tags$div(id="cite",
'Data compiled for ', tags$em('Coming Apart: The State of White America, 1960–2010'), ' by Charles Murray (Crown Forum, 2012).'
)
)
),
tabPanel("Data explorer",
fluidRow(
column(3,
selectInput("states", "States", c("All states"="", structure(state.abb, names=state.name), "Washington, DC"="DC"), multiple=TRUE)
),
column(3,
conditionalPanel("input.states",
selectInput("cities", "Cities", c("All cities"=""), multiple=TRUE)
)
),
column(3,
conditionalPanel("input.states",
selectInput("zipcodes", "Zipcodes", c("All zipcodes"=""), multiple=TRUE)
)
)
),
fluidRow(
column(1,
numericInput("minScore", "Min score", min=0, max=100, value=0)
),
column(1,
numericInput("maxScore", "Max score", min=0, max=100, value=100)
)
),
hr(),
DT::dataTableOutput("ziptable")
),
conditionalPanel("false", icon("crosshair"))
)
})
}
Alas, when I try to run this code I get the following error:
renderUI [/home/ignacio/learning_shinyauthr/063-superzip-example/server.R#218]
Hi, Paul!
Thank you for the great package.
A small issue. I tried to set the parameter "sodium_hashed = TRUE" as you described in the package description:
credentials <- callModule(shinyauthr::login, "login",
data = user_base, user_col = user, pwd_col = password,
sodium_hashed = TRUE,
log_out = reactive(logout_init()))
And, get an error as it seems this parameter is not in the list of available parameters.
Maybe there is some method how to protect passwords or how to change the default value for "sodium_hashed" parameter?
Thanks!
Andrii
Your package example looks really promising.
However, when I try to install shinyauthr via devtools::install_github("paulc91/shinyauthr")
the following error occurs:
Error: HTTP error 422.
No commit found for SHA: v1.2-rc
Rate limit remaining: 51/60
Rate limit reset at: 2018-12-06 09:16:22 UTC
In addition: Warning messages:
1: In untar2(tarfile, files, list, exdir) :
skipping pax global extended headers
2: In untar2(tarfile, files, list, exdir) :
skipping pax global extended headers
> sessionInfo()
R version 3.5.1 (2018-07-02)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 7 x64 (build 7601) Service Pack 1
Matrix products: default
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] usethis_1.4.0 devtools_2.0.1
loaded via a namespace (and not attached):
[1] Rcpp_1.0.0 ps_1.2.1 prettyunits_1.0.2 rprojroot_1.3-2
[5] withr_2.1.2 digest_0.6.18 crayon_1.3.4 assertthat_0.2.0
[9] R6_2.3.0 backports_1.1.2 magrittr_1.5 rlang_0.3.0.1
[13] debugme_1.1.0 cli_1.0.1 curl_3.2 fs_1.2.6
[17] remotes_2.0.2 testthat_2.0.1 callr_3.0.0 desc_1.2.0
[21] tools_3.5.1 glue_1.3.0 pkgload_1.0.2 compiler_3.5.1
[25] processx_3.2.0 base64enc_0.1-3 pkgbuild_1.0.2 sessioninfo_1.1.1
[29] memoise_1.1.0
First of all, thanks for this awesome package.
I have tried to replicate the example app (https://github.com/PaulC91/shinyauthr/blob/master/inst/shiny-examples/shinyauthr_example/app.R) which runs perfectly fine locally, but not working on shinyapp.io
I have checked the logs but there are no errors. After deployment, I can just see the black screen. Any suggestions on what could be the issue?
Hi, I'm trying to change the password during the run-time.
Therefore i have a input-field (id=newPW) where the User can enter his new password and a Button to confirm (id=changePW).
I try to change it by the following code:
observeEvent(input$changePW,{
credentials()$info$password <- input$newPW
})
Unfortunately I'm always getting the following error:
Warning: Error in <-: invalid (NULL) left side of assignment
Does anybody have an Idee how to change the data that is stored in credentials?
Hey Paul, is there a way to temporarily disable shinyauthr
login? This would be very handy in the testing phase of the app, when the developer might just want to focus on the main website development, bypassing the authorization step, saving time.
Thank you.
I am getting this error in Rv4.0.4 and v4.0.5 and when I commented out below lines from the server the app runs perfectly.
logout_init <- callModule(shinyauthr::logout,
id = "logout",
active = reactive(credentials()$user_auth))
credentials <- callModule(shinyauthr::login,
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
log_out = reactive(logout_init())
)
Any help much appreciated.
Thanks a lot for the package, with some basic db logic to store/retrieve user credentials it has become my go-to to implement basic auth in Shiny.
I think unit tests are needed to guard the package from bugs, testthat
is probably your best go-to on this one.
Since the latest update I'm getting two errors when trying to start my app:
Warning: Error in <observer:observeEvent(log_out())>: object 'js' not found
[No stack trace available]
Warning: Error in shiny::isTruthy: object 'js' not found
[No stack trace available]
I assume I'm doing something unintended, as your example app works without a problem. Happy to try and dig further, I was just hoping maybe you would have a quick idea of what might be going on. Thank you very much!
Hi,
First thank you for this package, i find it very useful !
I was wondering if it would be possible to use a submitButton
instead of actionButton
on the login page.
I did not try but it seems that pressing "Enter" with a submitButton triggers the action (but not actionButton).
I also see that styles don't seem to be available with submitButton (that's why you may have changed to actionButton ?).
Edit :
I guess my issue is related with returnClick.js, isn't it ?
In that case, pressing "Enter" does not work.
The inside of the package loginUI title cannot support Simple Chinese display function parameters, unable to work at run time. Is there a way to solve?
Thank U very much
Hi, Hope you are doing well.
I am trying to execute your example (shinyauthr_example). After execution, it becomes closed and generated an error of
Warning: Error in : in shinyauthr::login module call. Argument hashed is deprecated. shinyauthr now uses the sodium package for password hashing and decryption. If you had previously hashed your passwords with the digest package to use with shinyauthr, please re-hash them with sodium and use the sodium_hashed argument instead for decryption to work. Sorry for this breaking change but sodium hashing provides added protection against brute-force attacks on stored passwords.
54: stop
53: module
48: callModule
47: server [C:\shiny-examples\shinyauthr_example/app.R#43]
Error : in shinyauthr::login module call. Argument hashed is deprecated. shinyauthr now uses the sodium package for password hashing and decryption. If you had previously hashed your passwords with the digest package to use with shinyauthr, please re-hash them with sodium and use the sodium_hashed argument instead for decryption to work. Sorry for this breaking change but sodium hashing provides added protection against brute-force attacks on stored passwords.
Thanks,
Hi Paul, you have done a superb job, but is there any way to change the text displayed in the log in screen, even the button text. I will use this package in another country, so I need text in my native language.
Thnks in advance!!!
Hi Paul, i have issues with installing shinyauthr in Windows. I am getting the following error message:
devtools::install_github("paulc91/shinyauthr")
Downloading GitHub repo paulc91/shinyauthr@master
WARNING: Rtools is required to build R packages, but is not currently installed.
Please download and install Rtools 3.5 from http://cran.r-project.org/bin/windows/Rtools/.
√ checking for file 'C:\Users\Stratdigm\AppData\Local\Temp\Rtmp0KSrsU\remotesb41a3f7bec\PaulC91-shinyauthr-6830f43/DESCRIPTION' (381ms)
Installing package into ‘\Mac/Home/Documents/R/win-library/3.6’
(as ‘lib’ is unspecified)
'\Mac\Home\Documents'
CMD.EXE was started with the above path as the current directory.
UNC paths are not supported. Defaulting to Windows directory.
Thank you very much for developing this package, which perfectly solves the user and role rights issues. Here are a few half-baked suggestions I'd like you to consider:
Thanks.
library(shinyauthr)
shinyauthr::runExample("basic")
Error: shinyjs: Error parsing the JavaScript code provided.
Dear Paul, your package is really great, I'm learning this package, I saw that you gave several cases, but I'm currently using tinyMobile (https://github.com/RinteRface/shinyMobile), I tried many times, but did not succeed, can you give a simple case with shinyMobile,thank you very much!
Great package, it's been really useful - thanks!
On logout, whatever is visible in a dashboard body stays visible, and the login prompt simply pushes it down. Is there a way to intercept the logout and set to a blank tab - or a simpler option?
library(shiny)
library(shinyauthr)
library(shinyjs)
library(shinydashboard)
# dataframe that holds usernames, passwords and other user data
user_base <- data.frame(
user = c("user1", "a"),
password = c("pass1", ""),
permissions = c("admin", "standard"),
name = c("User One", "User Two"),
stringsAsFactors = FALSE
)
header <- dashboardHeader(title = 'Shiny Auth Test')
sidebar <- dashboardSidebar(
shinyauthr::logoutUI(id = 'logout', label = 'Log out', icon = icon('times-circle'))
,uiOutput('sidebarpanel')
)
body <- dashboardBody(
useShinyjs()
,shinyauthr::loginUI('login')
,uiOutput('body')
)
ui <- dashboardPage(header, sidebar, body, skin = 'purple')
server <- function(input, output, session) {
# call the logout module with reactive trigger to hide/show
logout_init <- callModule(shinyauthr::logout,
id = "logout",
active = reactive(credentials()$user_auth))
# call login module supplying data frame, user and password cols
# and reactive trigger
credentials <- callModule(shinyauthr::login,
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
log_out = reactive(logout_init()))
# pulls out the user information returned from login module
user_data <- reactive({credentials()$info})
output$sidebarpanel <- renderUI({
req(credentials()$user_auth)
div(
sidebarMenu(id = "sidebar"
,menuItem('Chart', tabName = 't_item1', icon = icon('chart-bar'))
,menuItem('Widget', tabName = 't_item2', icon = icon('ambulance'))
,menuItem('' , tabName = 't_blank')
)
)
})
output$body <- renderUI({
tabItems(
tabItem(tabName = "t_item1", h2("Chart tab content"))
,tabItem(tabName = "t_item2", h2("Widget tab content"))
,tabItem(tabName = "t_blank", h2(''))
)
})
}
shinyApp(ui = ui, server = server)
With current arrangement of pulling userBase
for authentication, problem arises if you change the password while the user is in session. As the program does not refresh userBase
, the old password would still be in effect until reloading the session.
I can think of two ways to fix this issue:
userBase
immediately after changeUserPassword
. Orsession$reload()
upon logout.I can do 1 to get around this issue for now, but I think option 2 is also worth considering.
Edit: also, is there a way to refresh credentials
?
Paul, Thanks for a very useful package.
I wonder whether the shinyauthr package also can be used with a shiny-rmarkdown document?
Up to now, I tried to call the shiny-rmd App (myshinyrmarkdown.Rmd) within the app.R below, but I receive an error that we cannot call run_App() within run_App() - is there an 'easy' way to achieve this?
Thanks in advance for a short clarification.
library(shinyauthr)
library(shiny)
user_base <- tibble::tibble(
user = c("user1", "user2", "user3"),
password = sapply(c("pass1", "pass2", "pass3"), sodium::password_store),
permissions = c("admin", "admin", "standard"),
name = c("U1","U2","U3")
)
ui <- fluidPage(
# logout button
div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
shinyauthr::loginUI(id = "login"),
uiOutput("sidebarpanel"),
)
server <- function(input, output, session) {
credentials <- shinyauthr::loginServer(
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
sodium_hashed = TRUE,
log_out = reactive(logout_init())
)
logout_init <- shinyauthr::logoutServer(
id = "logout",
active = reactive(credentials()$user_auth)
)
output$sidebarpanel <- renderUI({
req(credentials()$user_auth)
rmarkdown::run("myshinyrmarkdown.Rmd")
})
}
shinyApp(ui = ui, server = server)
Hi Paul,
Thanks a lot for this package! I'm very new to RShiny, and have made a very simple app without reactive elements. I'm trying to add a login screen to the app using shinyauthr based on the example on the README page on Github. The login dialog box and logout button show up as expected. But for some reason, the rest of the app shows below the login dialog box even if the user is not logged in (see attached images).
Here's a short app to demonstrate the problem. Like this example, my app does not have any reactive elements that are displayed through the server function. So my server function is empty except for the lines required for shinyauthr.
library(shiny)
library(shinydashboard)
library(shinyauthr)
# dataframe that holds usernames, passwords and other user data
user_base <- tibble::tibble(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
permissions = c("admin", "standard"),
name = c("User One", "User Two")
)
####### Define UI for application #######
ui <- fluidPage(
title = "Pattern Completion",
# Application title
titlePanel(HTML("<center>Data from New Exp</center>")),
# add logout button UI
div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
# add login panel UI function
shinyauthr::loginUI(id = "login"),
dashboardPage(
dashboardHeader(title=""),
dashboardSidebar(
sidebarMenu(
menuItem("Pilot Experiment", tabName= "enc_pilot",startExpanded = TRUE,
menuSubItem("Method", tabName="enc_pilot_method", icon=icon(name="tools", lib="font-awesome")),
menuSubItem("Results", tabName="enc_pilot_results", icon=icon(name="chart-line", lib="font-awesome")))
) #sidebarMenu
), #dashboardSidebar
dashboardBody(
tabItems(
tabItem(tabName="enc_pilot_method",
h2(HTML("<center>METHOD</center>")),
fluidRow(
box(width=12,
p(HTML("<strong>Objective:</strong> Some info goes here")),
),
box(width=12,
h3("Study Phase"),
p("More info goes here."),
),
box(width=12,
h3("Test Phase"),
p("Last box here."),
) #box
) #fluidRow
), #tabItem enc_pilot_method
tabItem(tabName="enc_pilot_results",
h2(HTML("<center>RESULTS</center>")),
fluidRow(
box(width=12,
h3("Results go here"),
), #box
box(width=12,
h3("More results"),
), #box
) #fluidRow
) #tabItem enc_pilot_results
) #tabItems
) #dashboardBody
) #dashboardPage
) #ui
####### Define server logic #######
server <- function(input, output, session) {
# call login module supplying data frame,
# user and password cols and reactive trigger
credentials <- shinyauthr::loginServer(
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
log_out = reactive(logout_init())
)
# call the logout module with reactive trigger to hide/show
logout_init <- shinyauthr::logoutServer(
id = "logout",
active = reactive(credentials()$user_auth)
)
output$user_table <- renderTable({
# use req to only render results when credentials()$user_auth is TRUE
req(credentials()$user_auth)
credentials()$info
})
}
shinyApp(ui = ui, server = server)
Any suggestions on how to fix this?
Hey @PaulC91 , congratulations for shinyauthr
, it is a very useful package!
Do you plan to submit to CRAN? It would be nice because it would facilitate the access and also be covered by RStudio Package Manager.
Thank you
I'm trying to add signup functionality. I'm using the prescribed code for login verification:
credentials <- callModule(
module = shinyauthr::login,
id = "login",
data = user_base,
user_col = user,
pwd_col = password_hash,
sodium_hashed = TRUE,
log_out = reactive(logout_init()))
In the above code, user_base
is a global variable. I tried to use reactive()
and eventReactive()
to replace the data
, but got the following error:
Error in UseMethod("tbl_vars") :
no applicable method for 'tbl_vars' applied to an object of class "c('reactiveExpr', 'reactive')"
Refreshing the page does not help, but I'm able to login with the previously created user after restarting the application (because global variable user_base
gets updated). But I'm unable to login with any user ID that's created in the current session.
Desired output:
On click of signup, a new row gets added to user_base
during the same session. Login attempt should be successful with the new user.
Hi @PaulC91, I'm just getting started with shinyauthr and it seems pretty straightforward. Thanks for putting this package together. I'm noticing that the login button has a color: white;
attribute which is a bit difficult to read:
Simply removing the attribute makes it much easier to see:
Associated PR coming shortly.
Thanks!
This will be resolved by #59
Along user and pass, Is it possible to add additional condition to enter shiny app?
More concretely, I would like to add date condition, that is date column for specific user have to be grater then today.
Something like this (server part):
credentials <- callModule(shinyauthr::login, "login",
data = user_base,
user_col = user,
pwd_col = password_hash,
sodium_hashed = TRUE,
log_out = reactive(logout_init()))
logout_init <- callModule(shinyauthr::logout, "logout", reactive(credentials()$user_auth))
observe({
if(credentials()$user_auth) { # & user_info$enddate > Sys.Date()
shinyjs::removeClass(selector = "body", class = "sidebar-collapse")
} else {
shinyjs::addClass(selector = "body", class = "sidebar-collapse")
}
})
user_info <- reactive({credentials()$info})
output$welcome <- renderText({
req(credentials()$user_auth)
glue("{user_info()$name}")
})
Please look at observe part. This code doesn't work, but demonstrate what I want.
Is it possible to add the logout button in the User panel of the shinydashboardPlus' dashboardUser interface? When adding the button as it is, the button is not visible. Builing an own function without the hide
function solves the problem, but then the login panel is not showing up after logout.
Hello,
Thanks for this package. It helps me a lot.
However, as said in the title, I always have to enter my passwords when using said package (I guess this will always happen when I'll open a shiny UI for login in).
Maybe there's some workaround, but I can't find it myself.
Maybe you know how to do that.
Thanks in advance.
Thank you very much for this great package. I have a use case for which we want to implement a token solution. Each token can be used exactly once. Each user can have multiple tokens. Unfortunately, shinyauthr checks that the username entered is unique in the user data. After a short look at the code in the login script I think that this can be easily rewritten. Would you consider this option? If it would help, I could also try to set up an appropriate pull-request.
Love this tool. Only one that works for my specific needs. Thank you for sharing. I have 1 problem where my Shiny app is on a server and if I add new users with a password the shinyauthr will not fetch the latest user/password from the database. Instead it uses the user/password list that was fetch during the first launch. The work around is to restart the shiny app which is not a good solution for me.
How would I trigger to check for the latest user/password list when the user clicks on the "Log in" button?
closing... same issue as #19
A declarative, efficient, and flexible JavaScript library for building user interfaces.
🖖 Vue.js is a progressive, incrementally-adoptable JavaScript framework for building UI on the web.
TypeScript is a superset of JavaScript that compiles to clean JavaScript output.
An Open Source Machine Learning Framework for Everyone
The Web framework for perfectionists with deadlines.
A PHP framework for web artisans
Bring data to life with SVG, Canvas and HTML. 📊📈🎉
JavaScript (JS) is a lightweight interpreted programming language with first-class functions.
Some thing interesting about web. New door for the world.
A server is a program made to process requests and deliver data to clients.
Machine learning is a way of modeling and interpreting data that allows a piece of software to respond intelligently.
Some thing interesting about visualization, use data art
Some thing interesting about game, make everyone happy.
We are working to build community through open source technology. NB: members must have two-factor auth.
Open source projects and samples from Microsoft.
Google ❤️ Open Source for everyone.
Alibaba Open Source for everyone
Data-Driven Documents codes.
China tencent open source team.