Shiny 中的用户身份验证

问题描述 投票:0回答:1

我正在使用

Shinyauthr
包对不同用户进行身份验证,以访问仪表板中的不同组件。 我有三个用户,用户1、用户2和用户3。 当用户 1 登录仪表板时,他们应该看到一个数据表, 当用户 2 登录仪表板时,他们应该看到一个直方图, 当用户 3 登录仪表板时,他们应该在一页中看到直方图和数据表。

我已经能够管理 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)
  )
r shiny
1个回答
0
投票

这是基于我的评论的 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

© www.soinside.com 2019 - 2024. All rights reserved.