我正在使用
Shinyauthr我已经能够管理 user1 和 user2 的身份验证，但我陷入了 user3 的逻辑代码。
app.R代码
library(shiny)
library(shinydashboard)
library(dplyr)
library(glue)
library(shinyauthr)
library(RSQLite)
library(DBI)
library(lubridate)
source("global.R")
# How many days should sessions last?
cookie_expiry <- 7
# This function must return a data.frame with columns user and sessionid. Other columns are also okay
# and will be made available to the app after log in.
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))
}
# This function must accept two parameters: user and sessionid. It will be called whenever the user
# successfully logs in with a password.
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 = "shinyauthr",
tags$li(
class = "dropdown",
style = "padding: 8px;",
shinyauthr::logoutUI("logout")
),
tags$li(
class = "dropdown",
tags$a(
icon("github"),
href = "https://github.com/paulc91/shinyauthr",
title = "See the code on github"
)
)
),
dashboardSidebar(
collapsed = TRUE,
div(textOutput("welcome"), style = "padding: 20px")
),
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%;'"))
)
),
uiOutput("testUI")
)
)
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_hash,
sodium_hashed = TRUE,
cookie_logins = TRUE,
sessionid_col = sessionid,
cookie_getter = get_sessions_from_db,
cookie_setter = add_session_to_db,
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)
)
observe({
if (credentials()$user_auth) {
shinyjs::removeClass(selector = "body", class = "sidebar-collapse")
} else {
shinyjs::addClass(selector = "body", class = "sidebar-collapse")
}
})
user_info <- reactive({
credentials()$info
})
user_data <- reactive({
req(credentials()$user_auth)
if (user_info()$permissions == "admin") {
DF2DT
} else if (user_info()$permissions == "standard") {
Hist
}
})
output$welcome <- renderText({
req(credentials()$user_auth)
glue("Welcome {user_info()$name}")
})
output$testUI <- renderUI({
req(credentials()$user_auth)
fluidRow(
column(
width = 12,
tags$h2(glue("Your permission level is: {user_info()$permissions}.
You logged in at: {user_info()$login_time}."
)),
box(
width = NULL,
status = "primary",
title = ifelse(user_info()$permissions == "admin", "DF Data", "Storms Data"),
DT::renderDT(user_data(), options = list(scrollX = TRUE))
),
box(width = NULL,
renderPlot(user_data()))
)
)
})
}
shiny::shinyApp(ui, server)
全局.R代码
library(tidyverse)
library(dplyr)
library(DT)
# User DB ####
user_base <- tibble(
user = c("user1", "user2", "user3"),
password = c("pass1", "pass2", "pass3"),
name =c("user 1" , "user 2", "user 3")
)
# Histogram ####
set.seed(41)
Distribution <- rnorm(20, mean = 50, sd = 20)
DistributionDF <- data.frame(var=Distribution)
Hist <- ggplot(DistributionDF, aes(var)) +
geom_histogram(binwidth=10, color="white", fill="#5DA7DB") +
theme_minimal()
Hist
# Table ####
Indicator <- c("Hypothermia", "CPAP use")
`2021 Q1` <- c(1, 0)
`2021 Q2` <- c(0.6, 0.1)
`2021 Q3` <- c(0.1, 0.6)
`2021 Q4` <- c(0, 1)
DF <- data.frame(Indicator, `2021 Q1`, `2021 Q2`, `2021 Q3`, `2021 Q4`, check.names= F)
# Variables for DT styling
percentageValues <- c(0,0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1)
fontColors <- c("#000","#000","#000","#000","#000","#000","#fff","#000","#fffffff","#000","#fff")
colorRamp <- c("#ff0000","#ffc000","#FFAE6D","#2146C7","#F0FF42","#FB2576","#c45911","#4C6793","#562B08","#533483","#385623")
# Create a Datatable from the DF
DF2DT <- datatable(DF) %>%
formatPercentage(
columns = c(2:5), 0
) %>%
formatStyle(
columns = c(2:5),
color = styleEqual(percentageValues, fontColors),
backgroundColor = styleEqual(percentageValues, colorRamp)
)
这是基于我的评论的 MWE：
library(shiny)
library(shinydashboard)
library(tidyverse)
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
)
ui <- dashboardPage(
dashboardHeader(
title="Testing..."
),
dashboardSidebar(
radioButtons("user", "User", c("User 1", "User 2", "User 3"))
),
dashboardBody(
box(width=4, plotOutput("plot")),
box(width=8, tableOutput("table"))
)
)
##### SERVER ####
server <- function(input, output, session) {
output$plot <- renderPlot({
if (input$user == "User 1") return (NULL)
mtcars %>%
ggplot() +
geom_point(aes(x=wt, y=mpg))
})
output$table <- renderTable({
if (input$user == "User 2") return (NULL)
mtcars
})
}
shinyApp(ui, server)
应该很容易适应使用你的
credentials()radioButtons