パスワード入力後のShinyアプリの起動（Shinydashboardを使用）

Question

この中で topic は、パスワード入力後にshinyappを起動する方法をよく説明しています。同じことをしようとしていますが、「navbarPage」の代わりに「dashboardPage」が欲しいのですが。

Do.call関数フォームの引数を「navbarPage」から「dashboardPage」に変更しようとしましたが、アプリがクラッシュします。

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

私のコードであなたが「正しい」道を歩み始めるのに十分かどうか疑問に思います。そうでない場合はお知らせください。

以下のコードは、ログインとパスワードが正しい場合、光沢のあるダッシュボードを表示します。

ただし、次の問題に対処する必要があります。

• Cssに問題があります。ログイン操作のために変更されたcssをshinydashboardのより標準的なものに「リセット」する必要があると思います（現在はすべて白です）
• パスワードが間違っている場合、最初のobserveはrenderUIで「勝ち」続け（2番目のobserveの有無にかかわらず、厳密に言えば不要であるため削除されます）、間違ったログインに関連するメッセージが表示されます実行されることはありません。

上記を修正するために試みることができることがいくつかあります。

• Cssの場合は、リセットするか、モーダルでエレガントにログインすることができます。
• 2つ目は、おそらくすべてのロジックを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とは少し異なるアプローチを取る別のソリューションです。 2番目の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月の更新

do.call関数をshinydashboardで機能させるための@Enzoの元のコードを理解することができました。下記を参照してください。これは@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))