Solución:
EDITAR 2019: Ahora podemos usar el paquete shinymanager para hacer esto: el invactivity La secuencia de comandos es detener el tiempo de espera de la página de inicio de sesión después de 2 minutos de inactividad para que no desperdicie recursos:
library(shiny)
library(shinymanager)
inactivity <- "function idleTimer()
var t = setTimeout(logout, 120000);
window.onmousemove = resetTimer; // catches mouse movements
window.onmousedown = resetTimer; // catches mouse movements
window.onclick = resetTimer; // catches mouse clicks
window.onscroll = resetTimer; // catches scrolling
window.onkeypress = resetTimer; //catches keyboard actions
function logout()
window.close(); //close the window
function resetTimer()
clearTimeout(t);
t = setTimeout(logout, 120000); // time is in milliseconds (1000 is 1 second)
idleTimer();"
# data.frame with credentials info
credentials <- data.frame(
user = c("1", "fanny", "victor", "benoit"),
password = c("1", "azerty", "12345", "azerty"),
# comment = c("alsace", "auvergne", "bretagne"), %>%
stringsAsFactors = FALSE
)
ui <- secure_app(head_auth = tags$script(inactivity),
fluidPage(
# classic app
headerPanel('Iris k-means clustering'),
sidebarPanel(
selectInput('xcol', 'X Variable', names(iris)),
selectInput('ycol', 'Y Variable', names(iris),
selected=names(iris)[[2]]),
numericInput('clusters', 'Cluster count', 3,
min = 1, max = 9)
),
mainPanel(
plotOutput('plot1'),
verbatimTextOutput("res_auth")
)
))
server <- function(input, output, session)
result_auth <- secure_server(check_credentials = check_credentials(credentials))
output$res_auth <- renderPrint(
reactiveValuesToList(result_auth)
)
# classic app
selectedData <- reactive(
iris[, c(input$xcol, input$ycol)]
)
clusters <- reactive(
kmeans(selectedData(), input$clusters)
)
output$plot1 <- renderPlot(
palette(c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3",
"#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999"))
par(mar = c(5.1, 4.1, 0, 1))
plot(selectedData(),
col = clusters()$cluster,
pch = 20, cex = 3)
points(clusters()$centers, pch = 4, cex = 4, lwd = 4)
)
shinyApp(ui = ui, server = server)
Publicación original:
Voy a responder el n. ° 1 y para el n. ° 2 simplemente puede ampliar mi ejemplo. Siguiendo este ejemplo, Cifre la contraseña con md5 para la aplicación Shiny. puedes hacer lo siguiente:
- Cree 2 páginas y si el usuario ingresa el nombre de usuario y la contraseña correctos, puede
renderUIy usehtmlOutputpara dar salida a su página - Puede diseñar la posición del cuadro con nombre de usuario y contraseña con
tagscomo hice yo y coloréalas si quieres también usandotags$style
Luego, puede mirar más en la página real y especificar qué se debe crear como resultado de diferentes usuarios. También puede buscar cuadros emergentes de JavaScript
EDITAR 2018: También eche un vistazo al ejemplo aquí https://shiny.rstudio.com/gallery/authentication-and-database.html
rm(list = ls())
library(shiny)
Logged = FALSE;
my_username <- "test"
my_password <- "test"
ui1 <- function()
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in"))),
tags$style(type="text/css", "#login font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;")
)
ui2 <- function()tagList(tabPanel("Test"))
ui = (htmlOutput("page"))
server = (function(input, output,session)
USER <- reactiveValues(Logged = Logged)
observe(
if (USER$Logged == FALSE)
if (!is.null(input$Login))
if (input$Login > 0)
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0)
if (Id.username == Id.password)
USER$Logged <- TRUE
)
observe(
if (USER$Logged == FALSE)
output$page <- renderUI(
div(class="outer",do.call(bootstrapPage,c("",ui1())))
)
if (USER$Logged == TRUE)
output$page <- renderUI(
div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
)
print(ui)
)
)
runApp(list(ui = ui, server = server))
Tuve la misma pregunta, tropecé con la respuesta anterior y me resultó demasiado difícil implementarla. Aparentemente, ha habido otros usuarios en SO con problemas similares para implementar la solución anterior.
He creado una solución alternativa mucho más simple usando la pestaña de agregar / quitar y shinyjs. Así es como funciona. Podría ayudar a aquellos que no quieran trabajar con dos funciones de IU separadas.
- Cree una pestaña de inicio de sesión donde los usuarios puedan iniciar sesión. Todas las demás pestañas aún no se muestran, ni tampoco la barra lateral.
- Cuando el inicio de sesión es exitoso: agregue las pestañas que realmente desea mostrar, elimine la pestaña de inicio de sesión (ya no es necesaria) y muestre la barra lateral con shinyjs.
Proporciono un ejemplo simple a continuación. Además, agregué algunas características que no son necesarias, como un historial de usuario que cuenta y limita el número de intentos de inicio de sesión, un registro de usuario y un controlador de mensajes, etc. Comenté esas características para simplificar las cosas, pero si está interesado, eche un vistazo. Tenga en cuenta que las funciones adicionales deben ejecutarse en un servidor.
La única desventaja de no usar shiny server pro es la falta de conexión https, que debe agregarse con otra solución si es realmente necesario.
Documenté un ejemplo simple y un enfoque con características adicionales en GitHub. Se puede encontrar una versión funcional de este último en shinyapps.io.
A continuación publico el código de la versión más simple de la aplicación que se centra en el inicio de sesión en sí.
Los nombres de usuario y las contraseñas necesarios para iniciar sesión son los siguientes:
username password
user123 loginpassword1
user456 loginpassword2
En una aplicación real, deben almacenarse como hashes en el servidor.
library("shiny")
library("shinyjs")
library("stringr")
# in case you want to send error messages when login is wrong
# add this to the /www folder in your shiny app (shiny server) as message-handler.js file
#
# // This recieves messages of type "testmessage" from the server.
# Shiny.addCustomMessageHandler("testmessage",
# function(message)
# alert(JSON.stringify(message));
#
# );
shinyApp(
ui = fluidPage(
useShinyjs(), # Set up shinyjs
# Layout mit Sidebar
sidebarLayout(
## Sidebar -----
shinyjs::hidden(
div(id = "Sidebar", sidebarPanel(
# > some example input on sidebar -----
conditionalPanel(
condition = "input.tabselected > 1",
dateRangeInput(inputId = "date",
label = "Choose date range",
start = "2018-06-25", end = "2019-01-01",
min = "2018-06-25", max = "2019-01-01",
startview = "year"))
))), # closes Sidebar-Panel
# Main-Panel ------
mainPanel(
tabsetPanel(
# > Login -------
tabPanel("Login",
value = 1,
br(),
textInput("username", "Username"),
passwordInput("password", label = "Passwort"),
# If you want to add custom javascript messages
# tags$head(tags$script(src = "message-handler.js")),
actionButton("login", "Login"),
textOutput("pwd")
), # closes tabPanel
id = "tabselected", type = "pills"
) # closes tabsetPanel
) # closes mainPanel
) # closes sidebarLayout
), # closes fluidPage
# Server ------
server = function(input, output, session){
user_vec <- c("user123" = "loginpassword1",
"user456" = "loginpassword2")
# I usually do run the code below on a real app on a server
# user <- reactiveValues(his = readRDS(file = "logs/user_his.rds"),
# log = readRDS(file = "logs/user_log.rds"),
# vec = readRDS(file = "logs/user_vec.rds"))
#
# where user_his is defined as follows
# user_his <- vector(mode = "integer", length = length(user_vec))
# names(user_his) <- names(user_vec)
observeEvent(input$login,
if (str_to_lower(input$username) %in% names(user_vec)) # is username in user_vec?
# Alternatively if you want to limit login attempts to "3" using the user_his file
# if (str_to_lower(input$username) %in% names(user$vec[user$his < 3]))
if (input$password == unname(user_vec[str_to_lower(input$username)]))
# nulls the user_his login attempts and saves this on server
# user$his[str_to_lower(input$username)] <- 0
# saveRDS(user$his, file = "logs/user_his.rds")
# Saves a temp log file
# user_log_temp <- data.frame(username = str_to_lower(input$username),
# timestamp = Sys.time())
# saves temp log in reactive value
# user$log <- rbind(user$log, user_log_temp)
# saves reactive value on server
# saveRDS(user$log, file = "logs/user_log.rds")
# > Add MainPanel and Sidebar----------
shinyjs::show(id = "Sidebar")
appendTab(inputId = "tabselected",
tabPanel("Tab 1",
value = 2
) # closes tabPanel,
)
appendTab(inputId = "tabselected",
tabPanel("Tab 2",
value = 3
) # closes tabPanel,
)
appendTab(inputId = "tabselected",
tabPanel("Tab 3",
value = 4
) # closes tabPanel
)
removeTab(inputId = "tabselected",
target = "1")
else # username correct, password wrong
# adds a login attempt to user_his
# user$his[str_to_lower(input$username)] <- user$his[str_to_lower(input$username)] + 1
# saves user_his on server
# saveRDS(user$his, file = "logs/user_his.rds")
# Messge which shows how many log-in tries are left
#
# session$sendCustomMessage(type = 'testmessage',
# message = paste0('Password not correct. ',
# 'Remaining log-in tries: ',
# 3 - user$his[str_to_lower(input$username)]
# )
# )
# closes if-clause
else # username name wrong or more than 3 log-in failures
# Send error messages with javascript message handler
#
# session$sendCustomMessage(type = 'testmessage',
# message = paste0('Wrong user name or user blocked.')
# )
# closes second if-clause
) # closes observeEvent
# Closes server
) # Closes ShinyApp
para el panel Shiny, esto también puede ayudar
library(shiny)
library(shinydashboard)
library(DT)
library(shinyjs)
library(sodium)
# Main login screen
loginpage <- div(id = "loginpage", style = "width: 500px; max-width: 100%; margin: 0 auto; padding: 20px;",
wellPanel(
tags$h2("LOG IN", class = "text-center", style = "padding-top: 0;color:#333; font-weight:600;"),
textInput("userName", placeholder="Username", label = tagList(icon("user"), "Username")),
passwordInput("passwd", placeholder="Password", label = tagList(icon("unlock-alt"), "Password")),
br(),
div(
style = "text-align: center;",
actionButton("login", "SIGN IN", style = "color: white; background-color:#3c8dbc;
padding: 10px 15px; width: 150px; cursor: pointer;
font-size: 18px; font-weight: 600;"),
shinyjs::hidden(
div(id = "nomatch",
tags$p("Oops! Incorrect username or password!",
style = "color: red; font-weight: 600;
padding-top: 5px;font-size:16px;",
class = "text-center"))),
br(),
br(),
tags$code("Username: myuser Password: mypass"),
br(),
tags$code("Username: myuser1 Password: mypass1")
))
)
credentials = data.frame(
username_id = c("myuser", "myuser1"),
passod = sapply(c("mypass", "mypass1"),password_store),
permission = c("basic", "advanced"),
stringsAsFactors = F
)
header <- dashboardHeader( title = "Simple Dashboard", uiOutput("logoutbtn"))
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"))
body <- dashboardBody(shinyjs::useShinyjs(), uiOutput("body"))
ui<-dashboardPage(header, sidebar, body, skin = "blue")
server <- function(input, output, session)
login = FALSE
USER <- reactiveValues(login = login)
observe(
if (USER$login == FALSE)
if (!is.null(input$login))
if (input$login > 0)
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
if(length(which(credentials$username_id==Username))==1)
pasmatch <- credentials["passod"][which(credentials$username_id==Username),]
pasverify <- password_verify(pasmatch, Password)
if(pasverify)
USER$login <- TRUE
else
shinyjs::toggle(id = "nomatch", anim = TRUE, time = 1, animType = "fade")
shinyjs::delay(3000, shinyjs::toggle(id = "nomatch", anim = TRUE, time = 1, animType = "fade"))
else
shinyjs::toggle(id = "nomatch", anim = TRUE, time = 1, animType = "fade")
shinyjs::delay(3000, shinyjs::toggle(id = "nomatch", anim = TRUE, time = 1, animType = "fade"))
)
output$logoutbtn <- renderUI(
req(USER$login)
tags$li(a(icon("fa fa-sign-out"), "Logout",
href="javascript:window.location.reload(true)"),
class = "dropdown",
style = "background-color: #eee !important; border: 0;
font-weight: bold; margin:5px; padding: 10px;")
)
output$sidebarpanel <- renderUI(
if (USER$login == TRUE )
sidebarMenu(
menuItem("Main Page", tabName = "dashboard", icon = icon("dashboard"))
)
)
output$body <- renderUI(
if (USER$login == TRUE )
tabItem(tabName ="dashboard", class = "active",
fluidRow(
box(width = 12, dataTableOutput('results'))
))
else
loginpage
)
output$results <- DT::renderDataTable(
datatable(iris, options = list(autoWidth = TRUE,
searching = FALSE))
)
runApp(list(ui = ui, server = server), launch.browser = TRUE)
valoraciones y reseñas
Te invitamos a patrocinar nuestro análisis añadiendo un comentario o valorándolo te damos las gracias.
¡Haz clic para puntuar esta entrada!
(Votos: 0 Promedio: 0)