Question

在此topic中，如何在输入一些密码后启动shinyapp。我正在努力做同样的事情，但我没有＆＃34; navbarPage＆＃34;，我希望有一个＆＃34; dashboardPage＆＃34;。

我尝试在do.call函数表单中更改参数＆＃39; navbarPage＆＃39;到＆＃39; dashboardPage＆＃39;，但应用程序崩溃了。

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(dashboardPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
    }
  })
})

runApp(list(ui = ui, server = server))

Answer 1

如果我的代码足以让你开始走上“正确”的道路，那我就开始了。如果不是这样，请告诉我。

以下代码，如果登录名和密码正确，将显示shinydashboard。

但需要解决以下问题：

css中存在问题。我认为你需要将为登录操作更改的css“重置”为更标准的shinydashboard（目前全部为白色）
如果密码错误，第一个observe将在renderUI上继续“获胜”（有或没有第二个observe，严格说来是不必要因此被淘汰）和相对于错误的消息登录永远不会执行。

您可以尝试修复上述内容。

对于css，你可以重新设置它，或者优雅地以模态登录。
对于第二个，也许您可以将所有逻辑带入renderUI调用。这样可以确保所有案例都得到执行。

但是如果它足够清楚，请告诉我。

这是代码：

rm(list = ls())
library(shiny)
library(shinydashboard)

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(dashboardHeader(),
          dashboardSidebar(),
          dashboardBody("Test"))
}


ui = (htmlOutput("page"))

server = function(input, output, session) {
  USER <- reactiveValues(Logged = Logged)

  observe({
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (length(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
            }
          }
        }
      }
    }
  })

  output$page <- renderUI({
    if (USER$Logged == FALSE) {
      do.call(bootstrapPage, c("", ui1()))
    } else {
      do.call(dashboardPage, #c(inverse=TRUE,title = "Contratulations you got in!",
              ui2())
    }
  })
}

shinyApp(ui, server)

2017年10月30日更新

似乎上面的代码不再起作用了（感谢@ 5249203指出这一点）。

我已经尝试修复它，但我没有设法使do.call函数与dashboardBody一起工作（如果有人知道某种方式，请告诉我！）。

因此，由于最近的shiny功能，我以另一种方式解决了这个问题。

看看你的想法（当然，通常解决方案只是一个需要扩展的模板）。

library(shiny)
library(shinydashboard)

Logged = FALSE
my_username <- "test"
my_password <- "test"

ui <- dashboardPage(skin='blue',
  dashboardHeader( title = "Dashboard"),
  dashboardSidebar(),
  dashboardBody("Test",
    # actionButton("show", "Login"),
  verbatimTextOutput("dataInfo")
    )
)

server = function(input, output,session) {

values <- reactiveValues(authenticated = FALSE)

# Return the UI for a modal dialog with data selection input. If 'failed' 
# is TRUE, then display a message that the previous value was invalid.
dataModal <- function(failed = FALSE) {
  modalDialog(
    textInput("username", "Username:"),
    passwordInput("password", "Password:"),
    footer = tagList(
      # modalButton("Cancel"),
      actionButton("ok", "OK")
    )
  )
}

# Show modal when button is clicked.  
# This `observe` is suspended only whith right user credential

obs1 <- observe({
  showModal(dataModal())
})

# When OK button is pressed, attempt to authenticate. If successful,
# remove the modal. 

obs2 <- observe({
  req(input$ok)
  isolate({
    Username <- input$username
    Password <- input$password
  })
  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) {
      Logged <<- TRUE
        values$authenticated <- TRUE
        obs1$suspend()
        removeModal()

    } else {
      values$authenticated <- FALSE
    }     
  }
  })


output$dataInfo <- renderPrint({
  if (values$authenticated) "OK!!!!!"
  else "You are NOT authenticated"
})

}

shinyApp(ui,server)

Answer 2

这是另一种解决方案，采用与@ Enzo相比略有不同的方法。它会创建第二个UI，因此用户无法在第一个菜单选项卡上看到应用程序显示的内容。唯一的缺点是所有内容基本上都被带到服务器端，这可能会导致代码出现问题，具体取决于它的编写方式。

library(shiny)
library(shinydashboard)

my_username <- "test"
my_password <- "abc"

###########################/ui.R/##################################

header <- dashboardHeader(title = "my heading")
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"))
body <- dashboardBody(uiOutput("body") )

ui <- dashboardPage(header, sidebar, body)

###########################/server.R/##################################

server <- function(input, output, session) {
  Logged <- FALSE

  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
            } 
          }
        } 
      }
    }    
  })

  output$sidebarpanel <- renderUI({
    if (USER$Logged == TRUE) { 
      dashboardSidebar(
        sidebarUserPanel("myuser", subtitle = a(icon("user"), "Logout", href="")),
        selectInput("in_var", "myvar", multiple = FALSE,
                    choices = c("option 1","option 2")),
        sidebarMenu(
          menuItem("Item 1", tabName = "t_item1", icon = icon("line-chart")),
          menuItem("Item 2", tabName = "t_item2", icon = icon("dollar")),
          menuItem("Item 3", tabName = "t_item3", icon = icon("credit-card")),
          menuItem("Item 4", tabName = "t_item4", icon = icon("share-alt"))
        ))}
  })

  output$body <- renderUI({
    if (USER$Logged == TRUE) {
      B <- c(2,3,4,3,7,5,4)

      box(
        title = p("Histogram", actionLink("Expand", "", icon = icon("expand"))), status = "primary", solidHeader = TRUE, width = 4,
        hist(B)
      )
    }
    if (USER$Logged == FALSE) {
      box(title = "Login",textInput("userName", "Username"),
          passwordInput("passwd", "Password"),
          br(),
          actionButton("Login", "Log in"))
    }
  })
}

shinyApp(ui, server)

2018年9月更新

我能够找出@ Enzo的原始代码，以使do.call功能与shinydashboard一起使用。请看下面。感谢@Enzo，我只是略微改变了一些线条。我认为这个解决方案比上面的第一个代码更好，因为它允许正确的输出代码保留在UI端。如果用户名和密码不正确，我还会添加一条消息弹出窗口。

rm(list = ls())
library(shiny)
library(shinydashboard)

my_username <- "test"
my_password <- "abc"

###########################/ui.R/##################################

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),
                  actionButton("Login", "Log in"),
                  verbatimTextOutput("dataInfo")
        )
    ),
    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(
  "You did it!"
)}

header <- dashboardHeader(title = "Test Login")
sidebar <- dashboardSidebar()
body <- dashboardBody(
  tags$head(tags$style("#dataInfo{color: red")),
  htmlOutput("page")
)

ui <- dashboardPage(header, sidebar, body)

###########################/server.R/##################################

server = (function(input, output,session) {

  Logged <- FALSE
  Security <- TRUE

  USER <- reactiveValues(Logged = Logged)
  SEC <- reactiveValues(Security = Security)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          if(my_username == Username & my_password == Password) {
            USER$Logged <- TRUE
          } else {SEC$Security <- FALSE}
        } 
      }
    }    
  })

  observe({
    if (USER$Logged == FALSE) {output$page <- renderUI({ui1()})}
    if (USER$Logged == TRUE) {output$page <- renderUI({ui2()})}
  })

  observe({
    output$dataInfo <- renderText({
      if (SEC$Security) {""}
      else {"Your username or password is not correct"}
    })
  })

})

runApp(list(ui = ui, server = server))

Answer 3

您的示例使用一个用户。我针对多种用户/密码情况进行了一些修改。这似乎对我有用。希望其他人可能会有所帮助：

library(shiny)
library(shinydashboard)
library(tidyverse)

user_base <- tibble(
  user =     c("Test1", "Test2", "Test3"),
  password = c("abc", "bcd", "cde"),
  name =     c("User1", "User2", "User3")
)

###########################/ui.R/##################################

header <- dashboardHeader(title = "my heading")
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"))
body <- dashboardBody(uiOutput("body") )
ui <- dashboardPage(header, sidebar, body)

###########################/server.R/##################################

server <- function(input, output, session) {
  Logged <- FALSE

  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(user_base$user == Username)
          Id.password <- which(user_base$password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <<- TRUE
            } 
          }
        } 
      }
    }    
  })

  output$sidebarpanel <- renderUI({
    if (USER$Logged == TRUE) { 
      dashboardSidebar(
        sidebarUserPanel("myuser", subtitle = a(icon("user"), "Logout", href="")),
        selectInput("in_var", "myvar", multiple = FALSE,
                    choices = c("option 1","option 2")),
        sidebarMenu(
          menuItem("Item 1", tabName = "t_item1", icon = icon("line-chart")),
          menuItem("Item 2", tabName = "t_item2", icon = icon("dollar")),
          menuItem("Item 3", tabName = "t_item3", icon = icon("credit-card")),
          menuItem("Item 4", tabName = "t_item4", icon = icon("share-alt"))
        ))}
  })

  output$body <- renderUI({
    if (USER$Logged == TRUE) {
      B <- c(2,3,4,3,7,5,4)

      box(
        title = p("Histogram", actionLink("Expand", "", icon = icon("expand"))), 
        status = "primary", solidHeader = TRUE, width = 4,
        hist(B)
      )
    }
    if (USER$Logged == FALSE) {
      box(title = "Login",textInput("userName", "Username"),
          passwordInput("passwd", "Password"),
          br(),
          actionButton("Login", "Log in"))
    }
  })
}

shinyApp(ui, server)

密码输入后启动Shiny app（使用Shinydashboard）

3 个答案: