r - 在Shiny中同步Dygraph和DateRangeInput

我想在一个有光泽的应用程序内同步一个音标和一个DateRangeInput。
下面的代码工作正常：我可以同时使用zoom选项和daterange，但是由于出现“乒乓”效果，因此无法使用dyRangeSelector：

library(xts)
library(shiny)
library(dygraphs)
library(lubridate)


data("co2")
data <- as.vector(coredata(as.xts(co2)))
serie <-  xts(x = data,order.by = seq(from=today(),by=1,length.out = length(data)))
ui <- fluidPage(
   titlePanel("Dygraph & date range input"),
   sidebarLayout(
      sidebarPanel(
        dateRangeInput('plage', label = "Selectionnez la période :",
                        start = start(serie), end = end(serie),
                         # min = start(serie), max = end(serie),
                       separator = " - ",
                       format = "dd mm yyyy", #"yyyy-mm-dd",
                       language = 'fr', weekstart = 1
        )
      ),
      mainPanel(
         dygraphOutput("dessin")
      )
   )
)

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

observeEvent(input$dessin_date_window,{
  start <- as.Date(ymd_hms(input$dessin_date_window[[1]]))
  stop  <- as.Date(ymd_hms(input$dessin_date_window[[2]]))
  updateDateRangeInput(session = session,
                       inputId = "plage",
                       start = start,end = stop
                       )
})

  output$dessin <- renderDygraph({
      dygraph(serie) %>%
    dyRangeSelector(
      dateWindow = input$plage+1) # +1 parce que voila...
  })
}

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

知道如何控制吗？
（没有笔画的更新功能... :(）

最佳答案

您可以定义将检查更改是由用户触发还是由反应性触发的值。这使您可以控制链反应。
因为书状图是输出，所以我需要添加一个中间值，该中间值仅在不由自动反应触发的情况下才会改变。因此，如果我们与书本互动，或者由日期选择器触发，则书本更新。但是，当日期选择器是由笔形变化触发时，则不是。

library(xts)
library(shiny)
library(dygraphs)
library(lubridate)


data("co2")
data <- as.vector(coredata(as.xts(co2)))
serie <-  xts(x = data,order.by = seq(from=today(),by=1,length.out = length(data)))

ui <- fluidPage(
  titlePanel("Dygraph & date range input"),
  sidebarLayout(
    sidebarPanel(
      dateRangeInput('plage', label = "Selectionnez la période :",
                     start = start(serie), end = end(serie),
                     separator = " - ",
                     format = "dd mm yyyy", #"yyyy-mm-dd",
                     language = 'fr', weekstart = 1
      )
    ),
    mainPanel(
      dygraphOutput("dessin")
    )
  )
)

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

  r <- reactiveValues(
    change_datewindow = 0,
    change_plage = 0,
    change_datewindow_auto = 0,
    change_plage_auto = 0,
    plage = c( start(serie), end(serie))
  )


  observeEvent(input$dessin_date_window, {
    message(crayon::blue("observeEvent_input_dessin_date_window"))
    r$change_datewindow <- r$change_datewindow + 1
    if (r$change_datewindow > r$change_datewindow_auto) {

      r$change_plage_auto <- r$change_plage_auto + 1
      r$change_datewindow_auto <- r$change_datewindow

      start <- as.Date(ymd_hms(input$dessin_date_window[[1]]))
      stop  <- as.Date(ymd_hms(input$dessin_date_window[[2]]))
      updateDateRangeInput(session = session,
                           inputId = "plage",
                           start = start,end = stop
      )
    } else {
      if (r$change_datewindow >= 10) {
        r$change_datewindow_auto <- r$change_datewindow <- 0
      }
    }
  })

  observeEvent(input$plage, {
    message("observeEvent_input_plage")
    r$change_plage <- r$change_plage + 1
    if (r$change_plage > r$change_plage_auto) {
      message("event input_year update")

      r$change_datewindow_auto <- r$change_datewindow_auto + 1
      r$change_plage_auto <- r$change_plage

      r$plage <- input$plage

    } else {
      if (r$change_plage >= 10) {
        r$change_plage_auto <- r$change_plage <- 0
      }
    }
  })

  output$dessin <- renderDygraph({
    message("renderDygraph")
    dygraph(serie) %>%
      dyRangeSelector(
        dateWindow = r$plage + 1) # +1 parce que voila...
  })
}

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

请注意，我在10以上时添加了计数器的重置。这也避免了R的触发值过高。计数器重置时，您可能会注意到一个小的爆发，具体取决于用户更换滑块的速度。您可以增加此值以使其不经常出现。

我添加了一些消息，以便您可以验证没有连锁反应。