反应性取决于条件确认对话框

Question

在这个最小的示例中，如何仅在确认更改 png -> svg 的 modalDialog 按钮后更新 textOutput。（svg-> png 不需要确认）

确认对话框应该仅适用于更改 png -> svg（以及其他未显示的条件），而不是返回方式。

由于主要输入会影响多个反应输出（未显示），因此最好使用反应值。

library(shiny)

ui = fluidPage(
  mainPanel(
    radioButtons("selectFormat", "Select Format",c("svg","png") ),
    uiOutput("textOut")
  )
)

server = function(session, input, output) {
  
  values<-reactiveValues()
  
  output$textOut <- renderUI({
    textOutput("selection")
  })
  
  observe({
    values[["format"]]<-input$selectFormat
  })
  
  output$selection <-renderText({
    paste(values[["format"]], "is selected" )
  })
  
  observeEvent(input$selectFormat, ignoreInit = T, {
    if (input$selectFormat=="svg") {
    showModal(modalDialog(
      title="Warning: When changing to '.svg' with condition X, Rstudio will crash",
      footer = tagList(actionButton("confirmSvg", "Select .svg anyway"),
                       
                       actionButton("confirmPng", "stay with .png as suggested")
      )
    ))
    }
  })
  
  observeEvent(input$confirmSvg, {
    updateRadioButtons(session,inputId = "selectFormat", selected="svg")
    removeModal()
  })
  observeEvent(input$confirmPng, {
    updateRadioButtons(session,inputId = "selectFormat", selected="png")
    removeModal()
  })
}

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

Answer 1

也许您正在寻找这个

library(shiny)

ui = fluidPage(
  mainPanel(
    radioButtons("selectFormat", "Select Format",choices=c("svg","png") ),
    uiOutput("textOut")
  )
)

server = function(session, input, output) {

  values <- reactiveValues()
  observe({values$sel <- input$selectFormat})
  
  observeEvent(input$selectFormat, ignoreInit = F, {
    if (input$selectFormat=="svg") {
      showModal(modalDialog(
        title="Warning: When changing to '.svg' with condition X, Rstudio will crash",
        footer = tagList(actionButton("confirmSvg", "Select .svg anyway"),

                         actionButton("confirmPng", "stay with .png as suggested")
        )
      ))
    }
  })

  observeEvent(input$confirmSvg, {
    updateRadioButtons(session,inputId = "selectFormat", selected="svg")
    removeModal()
  }, ignoreInit = T)
  observeEvent(input$confirmPng, {
    updateRadioButtons(session,inputId = "selectFormat", selected="png")
    removeModal()
  }, ignoreInit = TRUE)

  output$textOut <- renderUI({
    value <- values$sel # input$selectFormat
    if (tryCatch(is.numeric(input$confirmPng), error=function(e) FALSE) & 
        tryCatch(is.numeric(input$confirmSvg), error=function(e) FALSE)
    ) {
      if (input$selectFormat=="svg" & (input$confirmPng>0 | input$confirmSvg<1) ) {
        value <- "png"
      }
    }
    paste(value, "is selected" )
  })
  
}

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

Answer 2

尽管 YBS 的答案稍作修改后在最小示例 OP 中有效，但在现实世界中却没有。

所以我发现了这种方法，它适用于最小示例和现实世界：

library(shiny)

ui = fluidPage(
  mainPanel(
    radioButtons("selectFormat", "Select Format",choices=c("svg","png"),"svg" )
    ,uiOutput("textOut")
  )
)

server = function(session, input, output) {
  
  values<-reactiveValues(stop=FALSE,text="svg")
  
  observeEvent(input$selectFormat, ignoreInit=TRUE, {
    if(input$selectFormat=="svg") {
      showModal(modalDialog(
        title = "WARNING"
        ,".svg and other conditions (not shown) can cause Rstudio or browser to crash"
        ,easyClose = TRUE,
        footer = list(
          actionButton("confirmSvg", "Choose .svg (not recommended)"),
          actionButton("confirmPng", "Leave .png as suggested")
        ) )
      )
      values[["stop"]] <- TRUE
    } else {
      values[["text"]] <- input$selectFormat
      values[["stop"]] <- FALSE
    }
  })
  
  observeEvent(input$confirmSvg, {
    removeModal()
    updateRadioButtons(session,inputId = "selectFormat", selected="svg")
    values[["text"]] <- "svg"
    values[["stop"]] <- FALSE
  })
  
  observeEvent(input$confirmPng, {
    removeModal()
    updateRadioButtons(session,inputId = "selectFormat", selected="png")
    values[["stop"]] <- FALSE
    values[["text"]] <- "png"
  })
  
  output$textOut <- renderUI({
    validate(need(try(values[["stop"]]==FALSE),"not ready" ) )
    paste(values[["text"]], "is selected" )
  })
  
}

shinyApp(ui = ui, server = server)

反应性取决于条件确认对话框

reactivity dependent on conditional confirmation dialog

r

modal-dialog

shiny

reactive