在Shiny中同步Dygraph和DateRangeInput

Question

我想在Shiny App中同步dygraph和DateRangeInput.下面的代码工作正常:我可以同时使用缩放选项和日期范围,但我不能使用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)

知道如何控制吗？(dygraph没有更新功能...... :()

Answer 1

只需添加一个当前系列的反应,你应该是好的

  current_series <- reactive({
    range <- paste(input$plage[1], input$plage[2], sep = "/")
    serie[range]
  })

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

Answer 2

您可以定义值来检查更改是由用户触发还是由反应触发。这使您可以控制连锁反应。
\n因为dygraph是一个输出，所以我需要添加一个中间值，该中间值仅在不被自动反应触发时才会改变。因此，如果我们与它交互，或者由日期选择器触发，dygraph 就会更新。但当日期选择器是由图上的更改触发时则不然。

\n\n

library(xts)\nlibrary(shiny)\nlibrary(dygraphs)\nlibrary(lubridate)\n\n\ndata("co2")\ndata <- as.vector(coredata(as.xts(co2)))\nserie <-  xts(x = data,order.by = seq(from=today(),by=1,length.out = length(data)))\n\nui <- fluidPage(\n  titlePanel("Dygraph & date range input"),\n  sidebarLayout(\n    sidebarPanel(\n      dateRangeInput(\'plage\', label = "Selectionnez la p\xc3\xa9riode :",\n                     start = start(serie), end = end(serie),\n                     separator = " - ", \n                     format = "dd mm yyyy", #"yyyy-mm-dd",\n                     language = \'fr\', weekstart = 1\n      )\n    ),\n    mainPanel(\n      dygraphOutput("dessin")\n    )\n  )\n)\n\nserver <- function(input, output,session) {\n\n  r <- reactiveValues(\n    change_datewindow = 0,\n    change_plage = 0,\n    change_datewindow_auto = 0,\n    change_plage_auto = 0,\n    plage = c( start(serie), end(serie))\n  )\n\n\n  observeEvent(input$dessin_date_window, {\n    message(crayon::blue("observeEvent_input_dessin_date_window"))\n    r$change_datewindow <- r$change_datewindow + 1\n    if (r$change_datewindow > r$change_datewindow_auto) {\n\n      r$change_plage_auto <- r$change_plage_auto + 1\n      r$change_datewindow_auto <- r$change_datewindow\n\n      start <- as.Date(ymd_hms(input$dessin_date_window[[1]]))\n      stop  <- as.Date(ymd_hms(input$dessin_date_window[[2]]))\n      updateDateRangeInput(session = session,\n                           inputId = "plage",\n                           start = start,end = stop\n      )\n    } else {\n      if (r$change_datewindow >= 10) {\n        r$change_datewindow_auto <- r$change_datewindow <- 0\n      }\n    }\n  })\n\n  observeEvent(input$plage, {\n    message("observeEvent_input_plage")\n    r$change_plage <- r$change_plage + 1\n    if (r$change_plage > r$change_plage_auto) {\n      message("event input_year update")\n\n      r$change_datewindow_auto <- r$change_datewindow_auto + 1\n      r$change_plage_auto <- r$change_plage\n\n      r$plage <- input$plage\n\n    } else {\n      if (r$change_plage >= 10) {\n        r$change_plage_auto <- r$change_plage <- 0\n      }\n    }\n  })\n\n  output$dessin <- renderDygraph({\n    message("renderDygraph")\n    dygraph(serie) %>%\n      dyRangeSelector(\n        dateWindow = r$plage + 1) # +1 parce que voila...\n  })\n}\n\n# Run the application \nshinyApp(ui = ui, server = server)\n

\n\n

请注意，我在高于 10 时添加了计数器重置。这也避免了 R 的触发值过高。当计数器重置时，您可能会注意到一个小爆发，具体取决于用户更改滑块的速度。您可以增加该值以减少其出现的频率。

\n\n

我添加了一些消息，以便您可以验证是否存在连锁反应。

\n