在同步sliderInput和textInput

Question

考虑以下闪亮的应用：

library('shiny')

# User Interface/UI

ui <- fluidPage(

  titlePanel(
    'Slider and Text input update'
  ), # titlePanel

  mainPanel(

    # Slider input
    sliderInput(
      inputId = 'sliderValue',
      label = 'Slider value',
      min = 0,
      max = 1000,
      value = 500
    ), # sliderInput

    # Text input
    textInput(
      inputId = 'textValue',
      label = NULL
    ) # textInput

  ) # mainPanel

) # fluidPage


# Server logic

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

  observe({
    # Update vertical depth text box with value of slider
    updateTextInput(
      session = session,
      inputId = 'textValue',
      value = input$sliderValue
    ) # updateTextInput

#    updateSliderInput(
#      session = session,
#      inputId = 'sliderValue',
#      value = input$textValue
#    ) # updateSliderInput

  }) # observe

}

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

它允许用户更改滑块（sliderInput）的值，该滑块更新文本框中的文本（textInput）：

我希望这些能够同步工作。所以，而不仅仅是上面的滑块＆gt;文本框交互，我也想要相反：文本框＆gt;滑块。

如果您取消注释updateSliderInput组件，则这两个小组件会相互竞争;一个更新导致另一个更新，导致另一个更新，...

如何在避免两者同步的情况下避免这种情况？

Answer 1

一种方法是为每个输入使用observeEvent并添加条件if(as.numeric(input$textValue) != input$sliderValue)。这将帮助您从输入调用彼此递归更新函数。然后你的应用程序看起来像这样：

library('shiny')

  # User Interface/UI

  ui <- fluidPage(

    titlePanel(
      'Slider and Text input update'
    ), # titlePanel

    mainPanel(

      # Slider input
      sliderInput(
        inputId = 'sliderValue',
        label = 'Slider value',
        min = 0,
        max = 1000,
        value = 500
      ), # sliderInput

      # Text input
      textInput(
        inputId = 'textValue',
        value = 500,
        label = NULL
      ) # textInput

    ) # mainPanel

  ) # fluidPage


  # Server logic

  server <- function(input, output, session)
  {
    observeEvent(input$textValue,{
      if(as.numeric(input$textValue) != input$sliderValue)
      {
        updateSliderInput(
          session = session,
          inputId = 'sliderValue',
          value = input$textValue
        ) # updateSliderInput
      }#if


    })

    observeEvent(input$sliderValue,{
      if(as.numeric(input$textValue) != input$sliderValue)
      {
        updateTextInput(
          session = session,
          inputId = 'textValue',
          value = input$sliderValue
        ) # updateTextInput

      }#if

    })


  }

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

希望它有所帮助！

Answer 2

可以对上述代码进行一些修改，以解决当测试框中的输入为空时应用程序关闭的问题

   library('shiny')
   ui <- fluidPage(titlePanel('Slider and Text input update'),

                    mainPanel(
                      sliderInput(
                        inputId = 'sliderValue',
                        label = 'Slider value',
                        min = 0,
                        max = 1000,
                        value = 500
                      ),


                      textInput(
                        inputId = 'textValue',
                        value = 500,
                        label = NULL
                      )

                    ))


    # Server logic

    server <- function(input, output, session)
    {
      observeEvent(input$textValue, {
        print(input$textValue)
        if ((as.numeric(input$textValue) != input$sliderValue) &
            input$textValue != "" &  input$sliderValue != "")
        {
          updateSliderInput(
            session = session,
            inputId = 'sliderValue',
            value = input$textValue
          )
        } else {
          if (input$textValue == "") {
            updateSliderInput(session = session,
                              inputId = 'sliderValue',
                              value = 0)

          }
        }


      })

      observeEvent(input$sliderValue, {
        if ((as.numeric(input$textValue) != input$sliderValue) &
            input$sliderValue != "" & input$textValue != "")
        {
          updateTextInput(
            session = session,
            inputId = 'textValue',
            value = input$sliderValue
          )

        }

      })


    }

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