Question

我想询问是否有可能有一个确认对话框，包含两个按钮，闪亮。比如，如果我单击“删除”按钮，则会弹出对话框。用户选择并返回。该应用根据用户的选择行事。

Answer 1

使用sweetalertR

更新

#install_github("timelyportfolio/sweetalertR")
library(shiny)
library(sweetalertR)
runApp(shinyApp(
  ui = fluidPage(
    actionButton("go", "Go"),
    sweetalert(selector = "#go", text = "hello", title = "world")
  ),

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

示例1

您可以执行以下操作，请注意代码取自Demo on submit button with pop-up (IN PROGRESS)

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

ui =basicPage(
  tags$head(
    tags$style(type='text/css', 
               "select, textarea, input[type='text'] {margin-bottom: 0px;}"
               , "#submit {
          color: rgb(255, 255, 255);
          text-shadow: 0px -1px 0px rgba(0, 0, 0, 0.25);
          background-color: rgb(189,54,47);
          background-image: -moz-linear-gradient(center top , rgb(238,95,91), rgb(189,54,47));
          background-repeat: repeat-x;
          border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
        }"
    ),
    tags$script(HTML('
          Shiny.addCustomMessageHandler("jsCode",
            function(message) {
              eval(message.value);
            }
          );'
    ))
  )
  ,
  textInput(inputId = "inText", label = "", value = "Something here")
  ,
  actionButton(inputId = "submit", label = "Submit")
  #  
  #   alternative approach: button with pop-up
  #    , tags$button("Activate", id = "ButtonID", type = "button", class = "btn action-button", onclick = "return confirm('Are you sure?');" )
  ,
  tags$br()
  ,
  tags$hr()
  ,
  uiOutput("outText")
)
server = (
  function(session, input, output) {

    observe({
      if (is.null(input$submit) || input$submit == 0){return()}
      js_string <- 'alert("Are You Sure?");'
      session$sendCustomMessage(type='jsCode', list(value = js_string))
      text <- isolate(input$inText)
      output$outText <- renderUI({
        h4(text)
      })
    })

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

示例2

使用ShinyBS包

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

campaigns_list <- letters[1:10]

ui =fluidPage(
  checkboxGroupInput("campaigns","Choose campaign(s):",campaigns_list),
  actionLink("selectall","Select All"),
  bsModal("modalExample", "Yes/No", "selectall", size = "small",wellPanel(
    actionButton("no_button", "Yes"),
    actionButton("yes_button", "No")
    ))
)
server = function(input, output, session) {

  observe({
    if(input$selectall == 0) return(NULL) 
    else if (input$selectall%%2 == 0)
    {
      updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list)      
    }
    else
    {
      updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list,selected=campaigns_list)
    }
  })


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

编辑杏子

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

campaigns_list <- letters[1:10]

ui =fluidPage(
        checkboxGroupInput("campaigns","Choose campaign(s):",campaigns_list),
        actionLink("selectall","Select All"),
        bsModal("modalExample", "Yes/No", "selectall", size = "small",wellPanel(
                actionButton("yes_button", "Yes"),
                actionButton("no_button", "No")
        ))
)
server = function(input, output, session) {

        observeEvent(input$no_button,{
                updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list) 
        })

        observeEvent(input$yes_button,{
                updateCheckboxGroupInput(session,"campaigns","Choose campaign(s):",choices=campaigns_list,selected=campaigns_list)
        })
}
runApp(list(ui = ui, server = server))

Answer 2

不需要ShinyBS或Javascript。诀窍是使用modalDialog并将页脚设置为多个标签的tagList，通常是actionButton用于删除，而modalButton用于取消。以下是MWE

app.R

library(shiny)

ui = fluidPage(
   mainPanel(
       actionButton("createfile", "Create"),
       actionButton("deletefile", "Delete")
   )
)

# Define server logic required to draw a histogram
server = function(session, input, output) {

   observeEvent(input$createfile, {
       showModal(modalDialog(
           tagList(
               textInput("newfilename", label = "Filename", placeholder = "my_file.txt")
           ), 
           title="Create a file",
           footer = tagList(actionButton("confirmCreate", "Create"),
                            modalButton("Cancel")
           )
       ))
   })


   observeEvent(input$deletefile, {
       showModal(modalDialog(
           tagList(
               selectInput("deletefilename", label = "Delete a file", choices = list.files(pattern="*.txt"))
           ), 
           title="Delete a file",
           footer = tagList(actionButton("confirmDelete", "Delete"),
                            modalButton("Cancel")
           )
       ))
   })

   observeEvent(input$confirmCreate, {
       req(input$newfilename)
       file.create(input$newfilename)
       removeModal()
   })

   observeEvent(input$confirmDelete, {
       req(input$deletefilename)
       file.remove(input$deletefilename)
       removeModal()
   })
}

# Run the application 
shinyApp(ui = ui, server = server)

请注意，如果您使用闪亮的模块，则必须使用session$ns("inputID")而不是ns("inputID")。参见Tobias' answer here。

Answer 3

我修改了部分代码来调用

js_string <- 'confirm("Are You Sure?");'
session$sendCustomMessage(type='jsCode', list(value = js_string))

调用确认对话框而不是警告对话框。然后

tags$script(
            HTML('
                Shiny.addCustomMessageHandler(
                    type = "jsCode"
                    ,function(message) {
                    Shiny.onInputChange("deleteConfirmChoice",eval(message.value));
                })
            ')
)

发送确认对话框返回的值。然后我只是输入$ deleteConfirmChoice的值来确定要执行的操作。非常感谢你！我现在知道如何向R和Javascript发送和接收消息。

闪亮：如何创建确认对话框

3 个答案:

app.R