更新闪亮输入以匹配其他闪亮输入：无限循环

Question

我想在我的 Shiny 应用程序中拥有两个输入控制器实例，但我认为我必须做的是拥有两个输入并在其他输入发生变化时更新每个输入的值。这样，尽管它们具有不同的 ID，但它们在用户看来是相同的控件。

我预计会被告知不要做我想做的事情，但用例是我在 dashboardPage() 中有许多选项卡，其中只有两个共享控件。因此，将这两个页面的控件放在侧边栏中会使用户感到困惑。

我根据closely-related question 做了一个简单的、可行的示例来说明如何执行此操作（使用仪表板更清楚地说明我为什么要这样做），并通过说服提问者做其他事情来回答（这在他们的情况下工作，但在我的情况下没有工作）。该应用程序运行良好，只是随着它变得越来越复杂，计算有时需要足够长的时间，以至于我可以更改一个输入，然后在 Shiny 服务器有时间更新值之前更改另一个输入。这会导致无限反馈（输入 1 更新以匹配输入 2，而输入 2 更新以匹配输入 1，然后只要我愿意观看，这种情况就会重复）。

library(shiny)
library(shinydashboard)

ui = dashboardPage(
    dashboardHeader(title = "Example"),
    dashboardSidebar(
        sidebarMenu(
            menuItem("Tab 1", tabName = "tab1", icon = icon("chart-line")),
            menuItem("Tab 2", tabName = "tab2", icon = icon("chart-line")),
            menuItem("Other Tab", tabName = "tab3", icon = icon("project-diagram"))
        )
    ),
    dashboardBody(
        tabItems(
            # First tab content
            tabItem(tabName = "tab1",
                # Input first number
                numericInput("input1", label = "Input 1", value = 1, min=1, step=1)
                ),
            # Second tab content
            tabItem(tabName = "tab2",
                # Input second number
                numericInput("input2", label = "Input 2", value = 1, min=1, step=1)
                ),
            # Third tab content
            tabItem(tabName = "tab3", "Unrelated content")
            )
        )
    )

server = function(input, output, session) {
    # Update inputs to match each other
    observeEvent(input$input1, {
        updateSelectInput(session = session,
                          inputId = "input2",
                          selected = input$input1)})
    observeEvent(input$input2, {
        updateSelectInput(session = session,
                          inputId = "input1",
                          selected = input$input2)})
}

shinyApp(ui = ui, server = server)

问题：有哪些其他方法可以让单独的页面具有控制两个页面的匹配控件，但不必将这些控件放在每个页面上？子问题：这些方法中是否有任何一种方法可以避免无限循环问题？推论：我看到一篇文章，我认为是从辅助脚本渲染 UI 页面并将输入参数传递给这些脚本的 URL，这似乎是一个很好的策略，但我现在找不到这篇文章并且正在努力弄清楚我自己。

Answer 1

实际上要简单得多。您可以观察选择了哪个选项卡，而不是观察数字输入，并在用户到达该选项卡时更新特定的numericInput。所以我们只需要为sidebarMenu (id = "tabs", ...) 提供一个id 并观察这个输入变量的内容：

observe({
    if (req(input$tabs) == "tab2") {
      updateSelectInput(...)
    }
  })

使用键盘更改输入值：

用鼠标点击向上箭头改变输入值：

在通过点击列表呈现 tab1 时更改为 tab2：

---

更新代码：

library(shiny)
library(shinydashboard)

ui = dashboardPage(
  dashboardHeader(title = "Example"),
  dashboardSidebar(
    sidebarMenu(id = "tabs",
      menuItem("Tab 1", tabName = "tab1", icon = icon("chart-line")),
      menuItem("Tab 2", tabName = "tab2", icon = icon("chart-line")),
      menuItem("Other Tab", tabName = "tab3", icon = icon("project-diagram"))
    )
  ),
  dashboardBody(
    tabItems(
      # First tab content
      tabItem(tabName = "tab1",
              # Input first number
              numericInput("input1", label = "Input 1", value = 1000, min=1, step=1),
              plotOutput("plot1")
      ),
      # Second tab content
      tabItem(tabName = "tab2",
              # Input second number
              numericInput("input2", label = "Input 2", value = 1000, min=1, step=1),
              plotOutput("plot2")
      ),
      # Third tab content
      tabItem(tabName = "tab3", "Unrelated content")
    )
  )
)

server = function(input, output, session) {
  # some (not so) long computation
  long_comp1 <- reactive({
    x <- sample(input$input1, size=10000000, replace = TRUE)
    y <- sample(input$input1, size=10000000, replace = TRUE)
    m <- matrix(x, nrow = 500, ncol=200)
    n <- matrix(y, nrow = 200, ncol=500)
    p <- n %*% m  
    p
  })
  output$plot1 <- renderPlot({
    hist(long_comp1(), main = paste("input1 is", input$input1))
  })

  # some (not so) long computation
  long_comp2 <- reactive({
    x <- sample(input$input2, size=10000000, replace = TRUE)
    y <- sample(input$input2, size=10000000, replace = TRUE)
    m <- matrix(x, nrow = 500, ncol=200)
    n <- matrix(y, nrow = 200, ncol=500)
    p <- n %*% m  
    p
  })

  output$plot2 <- renderPlot({
    hist(long_comp2(), main = paste("input2 is", input$input2))
  })

  # Update inputs to match each other
  observe({
    if (req(input$tabs) == "tab2") {
      updateSelectInput(session = session,
                        inputId = "input2",
                        selected = input$input1)
    }
  })

  observe({
    if (req(input$tabs) == "tab1") {
      updateSelectInput(session = session,
                        inputId = "input1",
                        selected = input$input2)
    }
  })
}

shinyApp(ui = ui, server = server)