我知道Shiny Server Pro有密码控制功能。 问题是 Shiny 有函数 passwordInput()，就像 textInput() 有没有人想过如何做以下事情：
1) 只有在输入正确的密码后才能启动应用程序 2) 输入正确密码后启动应用程序部分（例如，我在shinydashboard中有一些选项卡，我想只通过密码访问其中一个）
谢谢！
【问题讨论】：
EDIT 2019：我们现在可以使用包shinymanager 来执行此操作：invactivity 脚本是在 2 分钟不活动后超时登录页面，这样您就不会浪费资源：
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)
原帖： 我将回答#1，对于#2，您可以简单地扩展我的示例。按照这个示例Encrypt password with md5 for Shiny-app.，您可以执行以下操作：
renderUI并使用htmlOutput输出您的页面tags设置用户名和密码来设置框的位置，如果您还想使用tags$style为它们着色
然后，您可以进一步查看实际页面并指定应根据不同用户创建的内容。也可以关注JavaScript Popup Boxes
EDIT 2018： 也可以看看这里的例子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))
【讨论】：
<<- 代替USER <<- reactiveValues(Logged = Logged) ？我认为反应足够<-
server，这里的想法是向用户显示不同的ui，你仍然可以在server = (function(input, output,session) {块中编写任何你想要的代码跨度>
除了第一个答案之外，您还可以通过将 shinymanager 与 scrypt 包结合使用来轻松加密您的密码。为此，您可以先生成一个密码并对其进行哈希处理：
library(scrypt)
password <- hashPassword("ice")
password #copy this hashed output and then paste it in your app's code
现在，如果我们采用前面的示例，您只需创建一个具有您的散列值（不是原始）的对象并在凭据中设置 is_hashed_password 参数即可对其进行修改到TRUE。
您无需将原始密码存储在脚本中即可访问应用程序（用户名：1）。
library(shiny)
library(shinymanager)
library(scrypt)
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();"
password <- "c2NyeXB0ABAAAAAIAAAAAVYhtzTyvRJ9e3hYVOOk63KUzmu7rdoycf3MDQ2jKLDQUkpCpweMU3xCvI3C6suJbKss4jrNBxaEdT/fBzxJitY3vGABhpPahksMpNu/Jou5"
# data.frame with credentials info
credentials <- data.frame(
user = c("1", "fanny", "victor", "benoit"),
password = password,
is_hashed_password = TRUE,
# 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)
【讨论】：
我不得不问同样的问题，偶然发现了上面的初始答案（使用两个不同的 UI），发现它对我来说太难实现了。显然，SO 上还有其他 users 存在类似问题来实现上述解决方案。
我使用附加/删除选项卡和 {shinyjs} 构建了一个更简单的解决方法。下面是它的工作原理。它可能会帮助那些不想使用两个单独的 UI 功能的人。
我在下面提供一个简单的例子。我进一步添加了一些不必要的功能，例如用户历史记录计数和限制登录尝试次数、用户日志和消息处理程序等。我将这些功能注释掉以保持简单，但如果您有兴趣看看。请注意，附加功能必须在服务器上运行。
不使用shiny server pro的唯一缺点是缺少https连接，如果确实需要，需要添加another work-around。
我在 GitHub 上记录了 simple example 和 approach with additional features。后者的工作版本可以在 shinyapps.io 上找到。
下面我发布了更简单版本的应用程序的代码，专注于登录本身。
登录所需的用户名和密码如下：
username password
user123 loginpassword1
user456 loginpassword2
在实际应用中，它们应该作为哈希值存储在服务器上。
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
【讨论】：
shinymanager 中提到的包似乎很正确，但它有一个主要问题，管理模块仅适用于 SQLlite 中的数据库。无论使用哪种数据库，我都打算制作一个管理模块，因为我在您的回答看起来不错之前就留下了。
对于闪亮的仪表板，这也可能有帮助
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)
【讨论】：
另一种设置密码的简单方法是使用 req() 并设置特定的密码值：
library(shiny)
if (interactive()) {
ui <- fluidPage(
passwordInput("password", "Password:"),
actionButton("go", "Go"),
verbatimTextOutput("value")
)
server <- function(input, output) {
output$value <- renderText({
req(input$password == "hi")
req(input$go)
isolate(input$password)
})
}
shinyApp(ui, server)
}
【讨论】：
要回答有关如何将上述现有方法之一实施到 {flexdashboard} 的附加问题：
在here 的讨论之后，我们可以让 {shinymanager} 与 {flexdashboard} 一起工作。我们需要做的就是添加一些自定义 css，这在 Rmarkdown 中很容易，因为我们可以在 setup 块之后添加一个 css 块。
但是，documentation 明确警告：
[将 {shinymanager} 与 {flexdashboard} 一起使用] 不是一种真正安全的方式，因为用户可以越过 使用开发者控制台进行身份验证...首选使用
shiny具有secure_app功能的应用程序。
---
title: "Old Faithful Eruptions"
output:
flexdashboard::flex_dashboard
runtime: shiny
---
```{r global, include=FALSE}
# load data in 'global' chunk so it can be shared by all users of the dashboard
library(datasets)
library(shinymanager)
data(faithful)
# define credentials
credentials <- data.frame(
user = c("shiny", "shinymanager"),
password = c("123", "12345"),
stringsAsFactors = FALSE
)
```
```{css}
/* without this css chunk shinymanager wont work */
.panel-auth {
position: fixed;
top:0;
bottom: 0;
left: 0;
right: 0;
background-color: #FFF;
opacity: 1;
z-index: 99997;
overflow-x: hidden;
overflow-y: scroll;
}
```
Column {.sidebar}
-----------------------------------------------------------------------
Waiting time between eruptions and the duration of the eruption for the
Old Faithful geyser in Yellowstone National Park, Wyoming, USA.
```{r}
selectInput("n_breaks", label = "Number of bins:",
choices = c(10, 20, 35, 50), selected = 20)
sliderInput("bw_adjust", label = "Bandwidth adjustment:",
min = 0.2, max = 2, value = 1, step = 0.2)
```
Column
-----------------------------------------------------------------------
### Geyser Eruption Duration
```{r}
renderPlot({
hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
xlab = "Duration (minutes)", main = "Geyser Eruption Duration")
dens <- density(faithful$eruptions, adjust = input$bw_adjust)
lines(dens, col = "blue")
})
auth_ui(id = "auth")
auth <- callModule(
module = auth_server,
id = "auth",
check_credentials = check_credentials(credentials) # credentials from above
)
```
解决来自 cmets 的附加问题：也可以在不同的页面上使用 {shinymanager}。我们还可以允许每页使用不同的用户和密码。只有在第一次访问页面时才会询问登录名，然后将其“解锁”。让它工作的技巧是在调用模块时使用不同的ids。
---
title: "Old Faithful Eruptions"
output:
flexdashboard::flex_dashboard
runtime: shiny
---
```{r global, include=FALSE}
# load data in 'global' chunk so it can be shared by all users of the dashboard
library(datasets)
library(shinymanager)
data(faithful)
# define credentials
credentials <- data.frame(
user = c("shiny", "shinymanager"),
password = c("123", "12345"),
stringsAsFactors = FALSE
)
credentials2 <- data.frame(
user = c("shiny", "manager"),
password = c("123", "45678"),
stringsAsFactors = FALSE
)
```
```{css}
/* without this css chunk shinymanager wont work */
.panel-auth {
position: fixed;
top:0;
bottom: 0;
left: 0;
right: 0;
background-color: #FFF;
opacity: 1;
z-index: 99997;
overflow-x: hidden;
overflow-y: scroll;
}
```
Page 1
=====================================
Column {.sidebar}
-----------------------------------------------------------------------
Waiting time between eruptions and the duration of the eruption for the
Old Faithful geyser in Yellowstone National Park, Wyoming, USA.
```{r}
selectInput("n_breaks", label = "Number of bins:",
choices = c(10, 20, 35, 50), selected = 20)
sliderInput("bw_adjust", label = "Bandwidth adjustment:",
min = 0.2, max = 2, value = 1, step = 0.2)
```
Column
-----------------------------------------------------------------------
### Geyser Eruption Duration
```{r}
renderPlot({
hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
xlab = "Duration (minutes)", main = "Geyser Eruption Duration")
dens <- density(faithful$eruptions, adjust = input$bw_adjust)
lines(dens, col = "blue")
})
auth_ui(id = "auth")
auth <- callModule(
module = auth_server,
id = "auth",
check_credentials = check_credentials(credentials) # credentials from above
)
```
Page 2
=====================================
Column {.sidebar}
-----------------------------------------------------------------------
Waiting time between eruptions and the duration of the eruption for the
Old Faithful geyser in Yellowstone National Park, Wyoming, USA.
```{r}
selectInput("n_breaks2", label = "Number of bins:",
choices = c(10, 20, 35, 50), selected = 20)
sliderInput("bw_adjust2", label = "Bandwidth adjustment:",
min = 0.2, max = 2, value = 1, step = 0.2)
```
Column
-----------------------------------------------------------------------
### Geyser Eruption Duration
```{r}
renderPlot({
hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks2),
xlab = "Duration (minutes)", main = "Geyser Eruption Duration")
dens <- density(faithful$eruptions, adjust = input$bw_adjust2)
lines(dens, col = "blue")
})
auth_ui(id = "auth2")
auth <- callModule(
module = auth_server,
id = "auth2",
check_credentials = check_credentials(credentials2) # credentials from above
)
```
【讨论】：
flexdashboard有多个页面时如何做这个认证，如图here？我尝试将代码添加到每个页面auth_ui(id = "auth") auth <- callModule(...)，但身份验证不起作用。你知道该怎么做吗？非常感谢。