输入密码后启动 Shiny 应用程序
Starting Shiny app after password input
我知道Shiny Server Pro中有一个密码控制的功能。
问题是 Shiny 有函数 passwordInput()，类似于 textInput()
有没有人想过如何做到以下几点：
1) 输入正确密码后才启动应用程序
2) 在正确输入密码后启动应用程序部分（例如，我在 shinydashboard 中有一些选项卡，我想只通过密码访问其中一个选项卡）
谢谢！
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)
原文Post:
我将回答#1，对于#2，您可以简单地扩展我的示例。按照此示例 Encrypt password with md5 for Shiny-app.，您可以执行以下操作：
- 创建 2 个页面，如果用户输入正确的用户名和密码，您可以
renderUI 并使用 htmlOutput 输出您的页面
- 您可以像我一样使用
tags 为带有用户名和密码的框的位置设置样式，如果您还想使用 tags$style 则可以为它们着色
然后您可以进一步查看实际页面并指定应根据不同用户创建的内容。您还可以查看 JavaScript Popup Boxes
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))
我不得不问同样的问题，偶然发现了上面的初始答案（使用两个不同的 UIs）并且发现它对我来说太难实现了。显然，在 SO 上还有其他 users 有类似的问题来实现上述解决方案。
我使用 append/remove 选项卡和 {shinyjs} 构建了一个更简单的解决方法。下面是它的工作原理。它可能会帮助那些不想使用两个单独的 UI 函数的人。
- 创建一个用户可以登录的登录选项卡。所有其他选项卡尚未显示，侧边栏也未显示。
- 登录成功时：
附加您实际想要显示的选项卡，删除登录选项卡（不再需要）并使用 {shinyjs} 显示侧边栏。
我在下面提供一个简单的例子。我进一步添加了一些不必要的功能，例如用户历史记录计数和限制登录尝试次数、用户日志和消息处理程序等。为了简单起见，我将这些功能注释掉了，但如果您有兴趣，请看一看。请注意，附加功能必须 运行 在服务器上。
不使用 shiny server pro 的唯一缺点是缺少 https 连接，如果确实需要，需要添加 another work-around。
我记录了一个 simple example and an approach with additional features on GitHub. A working version of the latter can be found on shinyapps.io。
下面我 post 应用程序的简单版本的代码侧重于登录本身。
登录需要的用户名和密码如下：
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
对于 Shiny 仪表板，这可能有助于
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)
}
除了第一个答案之外，您还可以通过将 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)
回答有关如何将上述现有方法之一实施到 {flexdashboard} 的附加问题：
我们可以让 {shinymanager} 在讨论后与 {flexdashboard} 一起工作 here。我们需要做的就是添加一些自定义 css，这在 Rmarkdown 中很容易，因为我们可以在设置块之后添加一个 css 块。
但是，documentation 明确警告：
[using {shinymanager} with {flexdashboard}] is not a really secure way because user can overpass the
authentification using developper console… Prefer use shiny
application with secure_app function.
---
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
)
```
解决评论中的附加问题：也可以在不同的页面上使用 {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
)
```
我知道Shiny Server Pro中有一个密码控制的功能。 问题是 Shiny 有函数 passwordInput()，类似于 textInput() 有没有人想过如何做到以下几点：
1) 输入正确密码后才启动应用程序 2) 在正确输入密码后启动应用程序部分（例如，我在 shinydashboard 中有一些选项卡，我想只通过密码访问其中一个选项卡）
谢谢！
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)
原文Post: 我将回答#1，对于#2，您可以简单地扩展我的示例。按照此示例 Encrypt password with md5 for Shiny-app.，您可以执行以下操作：
- 创建 2 个页面，如果用户输入正确的用户名和密码，您可以
renderUI并使用htmlOutput输出您的页面 - 您可以像我一样使用
tags为带有用户名和密码的框的位置设置样式，如果您还想使用tags$style 则可以为它们着色
然后您可以进一步查看实际页面并指定应根据不同用户创建的内容。您还可以查看 JavaScript Popup Boxes
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))
我不得不问同样的问题，偶然发现了上面的初始答案（使用两个不同的 UIs）并且发现它对我来说太难实现了。显然，在 SO 上还有其他 users 有类似的问题来实现上述解决方案。
我使用 append/remove 选项卡和 {shinyjs} 构建了一个更简单的解决方法。下面是它的工作原理。它可能会帮助那些不想使用两个单独的 UI 函数的人。
- 创建一个用户可以登录的登录选项卡。所有其他选项卡尚未显示，侧边栏也未显示。
- 登录成功时： 附加您实际想要显示的选项卡，删除登录选项卡（不再需要）并使用 {shinyjs} 显示侧边栏。
我在下面提供一个简单的例子。我进一步添加了一些不必要的功能，例如用户历史记录计数和限制登录尝试次数、用户日志和消息处理程序等。为了简单起见，我将这些功能注释掉了，但如果您有兴趣，请看一看。请注意，附加功能必须 运行 在服务器上。
不使用 shiny server pro 的唯一缺点是缺少 https 连接，如果确实需要，需要添加 another work-around。
我记录了一个 simple example and an approach with additional features on GitHub. A working version of the latter can be found on shinyapps.io。
下面我 post 应用程序的简单版本的代码侧重于登录本身。
登录需要的用户名和密码如下：
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
对于 Shiny 仪表板，这可能有助于
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)
}
除了第一个答案之外，您还可以通过将 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)
回答有关如何将上述现有方法之一实施到 {flexdashboard} 的附加问题：
我们可以让 {shinymanager} 在讨论后与 {flexdashboard} 一起工作 here。我们需要做的就是添加一些自定义 css，这在 Rmarkdown 中很容易，因为我们可以在设置块之后添加一个 css 块。
但是，documentation 明确警告：
[using {shinymanager} with {flexdashboard}] is not a really secure way because user can overpass the authentification using developper console… Prefer use
shinyapplication withsecure_appfunction.
---
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
)
```
解决评论中的附加问题：也可以在不同的页面上使用 {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
)
```