具有相互依赖的小部件的闪亮 renderUI

Question

我正在尝试使用 renderUI 来呈现多个小部件。另外，我希望我渲染的一些小部件依赖于我渲染的另一个小部件。

这是我想要的功能的一个可重现的小例子。

library(shiny)
library(purrr)

ui <- fluidPage(
    sidebarLayout(
        sidebarPanel(
            numericInput(
                'num_inputs'
                , label = 'How many inputs'
                , value = 1, min = 1, max = 100, step = 1
            )
            , uiOutput('widgets')
        )
        , mainPanel(
            h2('Output goes here')
        )
    )
)

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

    output$widgets <- renderUI({

        tags <- purrr::map(1:input$num_inputs, function(i) {
            list(
                h3(paste('Input', i))
                , selectInput(
                    paste0('input_1_', i)
                    , label = paste('Choose an option', i)
                    , choices = list('xxx', 'yyy')
                )
                , if (is.null(input[[paste0('input_1_', i)]]) || input[[paste0('input_1_', i)]] == 'xxx') {
                    selectInput(
                        paste0('input_2_', i)
                        , label = paste('Choose another option', i)
                        , choices = c('aaa', 'bbb')
                    )
                } else {
                    selectInput(
                        paste0('input_2_', i)
                        , label = paste('Choose another option', i)
                        , choices = c('ccc', 'ddd')
                    )
                }
            )
        })
        tagList(unlist(tags, recursive = FALSE))
    })
}

shinyApp(ui = ui, server = server)

当我运行它时，我观察到以下行为。当我尝试在输入input_1_1 下选择yyy 时，应用程序会短暂地将input_2_1 的选项从c('aaa', 'bbb') 更改为c('ccc', 'ddd')。但是，它会很快将 UI 重置为其原始设置。因此，我无法实际选择yyy。

我想这是因为 renderUI 中存在循环依赖关系。但是，我无法确定如何修复它们。有没有人推荐一个更好的方法来实现这个功能？

更新：

我已经在下面发布了我的 sessionInfo()

> sessionInfo()
R version 3.5.1 (2018-07-02)
Platform: x86_64-apple-darwin15.6.0 (64-bit)
Running under: macOS  10.14.3

Matrix products: default
BLAS: /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/3.5/Resources/lib/libRlapack.dylib

locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] shiny_1.2.0

loaded via a namespace (and not attached):
 [1] compiler_3.5.1  magrittr_1.5    R6_2.4.0        rsconnect_0.8.8 promises_1.0.1  later_0.7.3    
 [7] htmltools_0.3.6 tools_3.5.1     Rcpp_1.0.0      jsonlite_1.5    digest_0.6.19   xtable_1.8-2   
[13] httpuv_1.4.4.1  mime_0.5        rlang_0.3.4     purrr_0.3.2   

Answer 1

一般来说，我会使用observeEvent 与updateSelectInput 组合来更改可用的选项，而不是renderUI 中的if ... else ... 块。

类似：

library(shiny)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      numericInput(
        'num_inputs'
        , label = 'How many inputs'
        , value = 1, min = 1, max = 100, step = 1
      )
      , uiOutput('widgets')
    )
    , mainPanel(
      h2('Output goes here')
    )
  )
)

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

  tags <- eventReactive(
    eventExpr = input$num_inputs,
    valueExpr = {
      purrr::map(1:input$num_inputs, function(i) {
        list(
          h3(paste('Input', i))
          , selectInput(
            paste0('input_1_', i)
            , label = paste('Choose an option', i)
            , choices = list('xxx', 'yyy')
          )
          , 
          selectInput(
              paste0('input_2_', i)
              , label = paste('Choose another option', i)
              , choices = c('aaa', 'bbb')
          )
        )
      })
    }
  )

  output$widgets <- renderUI({ tagList(unlist(tags(), recursive = FALSE)) })

  observe({

    for (i in 1:input$num_inputs) {
      observeEvent(
        eventExpr = input[[paste0('input_1_', i)]],
        handlerExpr = {
          if (input[[paste0('input_1_', i)]] == 'xxx') {
            choices <- c('aaa', 'bbb')
          } else {
            choices <- c('ccc', 'ddd')
          }
          updateSelectInput(session, paste0('input_2_', i), choices = choices)
        }
      )
    }
  })

}

shinyApp(ui = ui, server = server)

Answer 2

以下解决方案基于@cwthom 提供的解决方案。当我尝试使用他们的解决方案时，我观察到一些关于 i 变量范围的奇怪行为。 （有关更多信息，请参阅我对他们的回答的评论）。

这是我的解决方案。

library(shiny)

ui <- fluidPage(
    sidebarLayout(
        sidebarPanel(
            numericInput(
                'num_inputs'
                , label = 'How many inputs'
                , value = 1, min = 1, max = 100, step = 1
            )
            , uiOutput('widgets')
        )
        , mainPanel(
            h2('Output goes here')
        )
    )
)

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

    tags <- eventReactive(
        eventExpr = input$num_inputs,
        valueExpr = {
            purrr::map(1:input$num_inputs, function(i) {
                list(
                    h3(paste('Input', i))
                    , selectInput(
                        paste0('input_1_', i)
                        , label = paste('Choose an option', i)
                        , choices = list('xxx', 'yyy')
                    )
                    , 
                    selectInput(
                        paste0('input_2_', i)
                        , label = paste('Choose another option', i)
                        , choices = c('aaa', 'bbb')
                    )
                )
            })
        }
    )

    output$widgets <- renderUI({ tagList(unlist(tags(), recursive = FALSE)) })

    observe({

        purrr::walk(1:input$num_inputs, function(i) {
            print(i)
            observeEvent(
                eventExpr = input[[paste0('input_1_', i)]],
                handlerExpr = {
                    if (input[[paste0('input_1_', i)]] == 'xxx') {
                        choices <- c('aaa', 'bbb')
                    } else {
                        choices <- c('ccc', 'ddd')
                    }
                    print(paste('updating input', i))
                    updateSelectInput(session, paste0('input_2_', i), choices = choices)
                }
            )
        })
    })
}

shinyApp(ui = ui, server = server)