挂起事件调度

Question

我有一个带有两个observeEvent()处理程序的应用程序，它们对输入A和输入B作出反应，并做一些事情。事件A的内容之一是更新输入B。

shinyApp(
  ui = fluidPage(
    selectInput("A", "Input A", c(1:5)),
    selectInput("B", "Input B", c(6:10))
  ),
  server = function(input, output, session) {
    observeEvent(input$A, ignoreInit = TRUE, {
      message("Doing A stuff")
      updateSelectInput(session, "B", selected = 10)
    })
    observeEvent(input$B, ignoreInit = TRUE, {
      message("Doing B stuff")
    })
  }
)

因此，改变输入A显然也会触发事件B。我希望事件B只在用户更改输入值时触发，而不是在updateInput完成时触发。是否有一种方法可以在计算表达式时挂起调度事件？我想要这样的：

shinyApp(
  ui = fluidPage(
    selectInput("A", "Input A", c(1:5)),
    selectInput("B", "Input B", c(6:10))
  ),
  server = function(input, output, session) {
    observeEvent(input$A, ignoreInit = TRUE, {
      message("Doing A stuff")
      suspendEventScheduling()
      updateSelectInput(session, "B", selected = 10)
      resumeEventScheduling()
    })
    observeEvent(input$B, ignoreInit = TRUE, {
      message("Doing B stuff")
    })
  }
)

观察员的文档提到了“暂停状态”，但我找不到如何实际使用它的任何例子。

Answer 1

在过去，我使用了一个哨兵值模式来处理这些类型的情况(参见下面)。但它总是感觉很脆弱。希望此功能请求能带来更好的选择。

library(shiny)

shinyApp(
  ui = fluidPage(
    selectInput("A", "Input A", c(1:5)),
    selectInput("B", "Input B", c(6:10))
  ),
  server = function(input, output, session) {
    is_server_update <- FALSE
    observeEvent(input$A, {
      message("Doing A stuff")
      updateSelectInput(session, "B", selected = 10)
      # Unchanged value doesn't trigger an invalidation
      if (input$B != 10) {
        is_server_update <<- TRUE
      }
    }, ignoreInit = TRUE)
    observeEvent(input$B, {
      if (is_server_update) {
        is_server_update <<- FALSE
      } else {
        message("Doing B stuff")
      }
    }, ignoreInit = TRUE)
  }
)

Answer 2

在玩了几次之后，我收集了一些JavaScript来完成这个任务。

这样做的目的是跟踪其值不应改变的暂停输入。使用事件钩子，我们可以检查一个输入事件是否针对一个挂起的输入。如果是这样的话，就阻止它进行更改。但关键的是，UI仍然会得到更新--只是不会更新闪亮的输入值。

然后，我们还需要一些帮助函数来管理挂起的输入列表。这是JavaScript和R助手：

js <-
  "
  // Don't actually modify the Shiny object in 'real' code!
  Shiny.suspendedInputs = new Set();
  
  $(document).on('shiny:inputchanged', function(event) {
    Shiny.suspendedInputs.has(event.target.id) && event.preventDefault();
  })
  
  Shiny.addCustomMessageHandler('suspendinput', function(message) {
    Shiny.suspendedInputs.add(message.id);
  });
  
  Shiny.addCustomMessageHandler('resumeinput', function(message) {
    Shiny.suspendedInputs.delete(message.id);
    
    // Last value that Shiny got is probably out of sync with the UI
    Shiny.forgetLastInputValue(message.id);
  })
  "

suspendInput <- function(inputId, session = getDefaultReactiveDomain()) {
  session$sendCustomMessage("suspendinput", list(id = inputId))
}

resumeInput <- function(inputId, session = getDefaultReactiveDomain()) {
  session$sendCustomMessage("resumeinput", list(id = inputId))
}

几乎所有的挂起和恢复消息都应该在不同的刷新周期中发送。否则，将在任何更新的输入事件触发之前执行简历，从而不会发生任何事情。另一个确保“正确”使用的助手应该是：

suspendForNextFlush <- function(inputId, session = getDefaultReactiveDomain()) {
  session$onFlush(function() suspendInput(inputId, session = session))
  session$onFlushed(function() resumeInput(inputId, session = session))
}

现在，我们已经准备好将所有的东西整合到一个工作的应用程序中：

library(shiny)

shinyApp(
  ui = fluidPage(
    tags$script(HTML(js)),
    selectInput("A", "Input A", c(1:5)),
    selectInput("B", "Input B", c(6:10))
  ),
  server = function(input, output, session) {
    observeEvent(input$A, {
      message("Doing A stuff")
      suspendForNextFlush("B")
      updateSelectInput(session, "B", selected = 10)
    }, ignoreInit = TRUE)
    observeEvent(input$B, {
      message("Doing B stuff")
    }, ignoreInit = TRUE)
  }
)