在 Shiny 中同步 Dygraph 和 DateRangeInput

Question

I would like to synchronise a dygraph and a DateRangeInput inside a Shiny App. The code bellow works fine: I can simultaneously use the zoom option And the daterange but I can't use the dyRangeSelector because of a "ping pong" Effect:

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)

Any idea how to control that? (there is no update function for dygraph... :( )

Answer 1

Just add a reactive for the current series and you should be good

  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

You can define values that will check if the change is triggered by the user or by the reactivity. This allows you to control a chain reaction.
Because the dygraph is an output, I need to add an intermediate value that will change only if not triggered by the automatic reaction. Thus, the dygraph updates if we interact with it, or if triggered by the date selector. But not when the date selector is triggered by a change on the dygraph.

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)

Note that I added a reset of the counters when above 10. This is too avoid the trigger value to be to high for R. When the counter resets, you may notice a small outburst, depending on the speed your users change the slider. You can increase this value to make it appear less often.

I added some messages so that you can verify that there is not chain reaction.

Answer 3

You can use retainDateWindow = TRUE in dyRangeSelector() .

output$dessin <- renderDygraph({
  dygraph(serie) %>%
    dyRangeSelector(
      dateWindow = input$plage+1, retainDateWindow = TRUE)
})

I hope this helps you.