r - 如何根据 shinymanager 凭据禁用 Shiny 功能

Question

如何根据使用 shinymanager 输入的凭据使用 shinyjs 禁用功能？

在下面的示例中，我向凭据添加了一个 level 字段，如果用户级别大于零，我想禁用 extraOutput。但是应用程序崩溃并出现错误:Operation not allowed without an active reactive context.

library(shiny)
library(shinymanager)
library(shinyjs)

# define some credentials
credentials <- data.frame(
  user = c("shiny", "shiny2"), # mandatory
  password = c("111", "111"), # mandatory
  start = c("2015-04-15"), # optinal (all others)
  expire = c(NA, "2032-12-31"),
  admin = c(FALSE, TRUE),
  comment = "Simple and secure authentification mechanism 
  for single ‘Shiny’ applications.",
  stringsAsFactors = FALSE,
  moreInfo = c("someData1", "someData2"),
  level = c(2, 0)
)

ui <- fluidPage(
  shinyjs::useShinyjs(),
  tags$h2("My secure application"),
  verbatimTextOutput("auth_output"),
  verbatimTextOutput("extraOutput")
)

# Wrap your UI with secure_app
ui <- secure_app(ui)


server <- function(input, output, session) {
  # call the server part
  # check_credentials returns a function to authenticate users
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  if(reactiveValuesToList(res_auth)$level > 0) disable(output$extraOutput) 
  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })
  output$extraOutput <- renderPrint({
    print("extra output based on level")
  })

  # your classic server logic

}

shinyApp(ui, server)

编辑------------------------

我设法用变量 shinymanager_where 做到了，但我觉得这是一个 hack，所以我会留下问题以获得更好的答案。

ui <- fluidPage(
    shinyjs::useShinyjs(),
    tags$h2("My secure application"),
    verbatimTextOutput("auth_output"),
    actionBttn(
        "extraOutput",
        label = "testButtonDisabled",
        icon = NULL,
        style = "unite",
        color = "default",
        size = "md",
        block = FALSE,
        no_outline = TRUE
    )
)

# Wrap your UI with secure_app
ui <- secure_app(ui)


server <- function(input, output, session) {
  # call the server part
  # check_credentials returns a function to authenticate users
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  observeEvent(input$shinymanager_where, {
      if(input$shinymanager_where == "application"){
          print(reactiveValuesToList(res_auth))
          print(reactiveValuesToList(res_auth)$level)
          if(reactiveValuesToList(res_auth)$level > 0){
              shinyjs::disable("extraOutput")
          }
      }
  })
  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })
  observeEvent(input$extraOutput,{
    print("extra output based on level")
  })

  # your classic server logic

}

shinyApp(ui, server)

Answer 1

将凭据放入 react 值中。然后它可以重新用于应用基于凭据作为输入参数的初始 UI 设置

library(shiny)
library(shinymanager)
library(shinyjs)

# define some credentials
credentials <- data.frame(
  user = c("shiny", "shiny2"), # mandatory
  password = c("111", "111"), # mandatory
  start = c("2015-04-15"), # optinal (all others)
  expire = c(NA, "2032-12-31"),
  admin = c(FALSE, TRUE),
  comment = "Simple and secure authentification mechanism 
  for single ‘Shiny’ applications.",
  stringsAsFactors = FALSE,
  moreInfo = c("someData1", "someData2"),
  level = c(2, 0)
)

ui <- fluidPage(
  shinyjs::useShinyjs(),
  tags$h2("My secure application"),
  verbatimTextOutput("auth_output"),
  verbatimTextOutput("extraOutput")
)

# Wrap your UI with secure_app
ui <- secure_app(ui)


server <- function(input, output, session) {
  # call the server part
  # check_credentials returns a function to authenticate users
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  # Create reactive values including all credentials
  creds_reactive <- reactive({
    reactiveValuesToList(res_auth)
  })

  # Hide extraOutput only when condition is TRUE
  observe({
    if (!is.null(creds_reactive()$level) && creds_reactive()$level > 0) shinyjs::hide("extraOutput")
  })

  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })

  output$extraOutput <- renderPrint({
    print("extra output based on level")
  })

  # your classic server logic
}

shinyApp(ui, server)