在 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

您可以定義將檢查更改是由用戶觸發還是由反應觸發的值。 這使您可以控制連鎖反應。
因為 dygraph 是一個輸出，我需要添加一個中間值，只有在自動反應不觸發時才會改變。 因此，如果我們與之交互，或者如果由日期選擇器觸發，則 dygraph 會更新。 但不是當日期選擇器由 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)

請注意，我在超過 10 時添加了計數器的重置。這也避免了 R 的觸發值太高。當計數器重置時，您可能會注意到一個小的爆發，具體取決於用戶更改滑塊的速度。 您可以增加此值以減少它出現的頻率。

我添加了一些消息，以便您可以驗證沒有連鎖反應。

Answer 3

您可以在dyRangeSelector()中使用retainDateWindow = TRUE 。

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

我希望這可以幫助你。