Синхронизировать Dygraph и DateRangeInput в Shiny

Question

Я хотел бы синхронизировать динамик и 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

Вы можете определить значения, которые будут проверять, инициировано ли изменение пользователем или реактивностью. Это позволяет контролировать цепную реакцию.
Поскольку диграф является выходным, мне нужно добавить промежуточное значение, которое будет изменяться только в том случае, если оно не будет вызвано автоматической реакцией. Таким образом, диграф обновляется, если мы взаимодействуем с ним или запускается селектором даты. Но не тогда, когда селектор даты срабатывает при изменении графика.

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. Когда счетчик сбрасывается, вы можете заметить небольшой выброс, в зависимости от скорости, с которой пользователи меняют ползунок. Вы можете увеличить это значение, чтобы оно появлялось реже.

Я добавил несколько сообщений, чтобы вы могли убедиться, что цепной реакции нет.

Answer 3

Ты можешь использовать retainDateWindow = TRUE в dyRangeSelector(),

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

Я надеюсь, это поможет вам.