Блестящий 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)

Когда я запускаю это, я наблюдаю следующее поведение. Когда я пытаюсь выбрать yyy для ввода input_1_1, приложение кратко меняет параметры для input_2_1 с c('aaa', 'bbb') на c('ccc', 'ddd'). Тем не менее, он очень быстро сбрасывает интерфейс к его первоначальным настройкам. Поэтому я не могу выбрать yyy.

Я предполагаю, что это происходит потому, что в renderUI есть циклические зависимости. Однако я не могу определить, как их исправить. У кого-нибудь есть рекомендации по лучшему способу достижения этой функциональности?

UPDATE:

Я разместил свою 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

Приведенное ниже решение основано на решении, предоставленном @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)

Answer 2

В целом для этого я бы использовал observeEvent в сочетании с updateSelectInput для изменения доступных вариантов вместо блока if ... else ... в renderUI.

Что-то вроде:

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)