在 Shiny 模块中调用 updateDateRangeInput

Question

我有一个闪亮的应用程序，在一个页面上使用相同的日期范围包含多个 plot_ly 图表。出于复杂的原因，我希望将每个图表放在一个单独的模块中，并对plot_ly 缩放做出反应。

我做这个预模块的方法是捕获plotly_relayout 并让它调用updateDateRangeInput 将整个页面设置为该范围，然后通过我的其他plot_ly 图表级联。现在我们正在模块化这些图表，我无法拥有相同的行为。我捕获了重绘事件，但在父日期范围内调用 updateDateRangeInput 似乎没有效果。

我尝试过使用命名空间的会话以及传递父会话并使用它调用。

非常简化的代码：

app.R：

library(shiny)

source("mod.R", local = TRUE)

ui <- shinyUI(fluidPage(
  chartTimeseriesUI("myseries")
  , dateRangeInput("dateRange", "Select Date Range:"
                   , start = Sys.Date() - 600
                   , end = Sys.Date()
                   , min = Sys.Date() - 1200
                   , max = Sys.Date()
  )
))

server <- shinyServer(function(input, output, session) {
  callModule(chartTimeseries, id = "myseries", reactive(input$dateRange), session)
})

shinyApp(ui = ui, server = server)

mod.R：

chartTimeseriesUI <- function(id) {
  ns <- NS(id)
  plotlyOutput(outputId = ns("timeseries"))
}

chartTimeseries <- function(input, output, session, dateRange, psession) {
  regionRedraw <- reactive({
    print("I'm in redraw")
    d <- event_data("plotly_relayout", source = "timeseries") 
    if(is.null(d)) { # double click
      startdate <- Sys.Date() - 600
      enddate <- Sys.Date() 
    } else {
      xstart <- d$`xaxis.range[0]`
      xend <- d$`xaxis.range[1]`

      if (is.null(xstart)) { 
        startdate <- Sys.Date() - 600
        enddate <- Sys.Date()
      } else {
        # Take our X time and convert it out of milliseconds
        startdate <- as.POSIXlt(xstart/1000, origin="1970-01-01", tz="America/New_York")  
        enddate <- as.POSIXlt(xend/1000, origin="1970-01-01", tz="America/New_York")
      }
    }

    absmindate <- Sys.Date() - 1200
    absmaxdate <- Sys.Date() 
    updateDateRangeInput(psession, dateRange, label="Now for a new range:", start=startdate, end=enddate, min=absmindate, max=absmaxdate)
  })

  observe({
    print("date range changed!")
    d <- regionRedraw()
  })

  output$timeseries <- renderPlotly({
    rangestart <- dateRange()[1]
    rangeend <- dateRange()[2]
    diff_in_days = as.numeric(difftime(rangeend, rangestart, units = "days"))
    tm <- seq(0, diff_in_days, by = 10)
    x <- rangeend - tm
    y <- rnorm(length(x))

    p <- plot_ly(x = ~x
                , y = ~y
                , type = "scatter"
                , mode = "markers"
                , text = paste(tm, "days from today")
                , source = "timeseries")
  })
}

输出

[1] "date range changed!"
[1] "I'm in redraw"

然后当我选择一个区域时，我得到：

[1] "date range changed!"
[1] "I'm in redraw"

并且绘图放大，日期范围不会更改为新选择，dateRangeInput 标签也不会更改。

感谢您的帮助！

Answer 1

我能够通过更新模块之外的日期范围来实现此功能： 模块：

chartTimeseriesUI <- function(id) {
  ns <- NS(id)
  plotlyOutput(outputId = ns("timeseries"))
}

chartTimeseries <- function(input, output, session, dateRange) {
  regionRedraw <- reactive({
    print("I'm in redraw")
    d <- event_data("plotly_relayout", source = "timeseries") 
    if(is.null(d)) { # double click
      startdate <- Sys.Date() - 600
      enddate <- Sys.Date() 
    } else {
      xstart <- d$`xaxis.range[0]`
      xend <- d$`xaxis.range[1]`

      if (is.null(xstart)) { 
        startdate <- Sys.Date() - 600
        enddate <- Sys.Date()
      } else {
        # Take our X time and convert it out of milliseconds
        startdate <- as.POSIXlt(xstart/1000, origin="1970-01-01", tz="America/New_York")  
        enddate <- as.POSIXlt(xend/1000, origin="1970-01-01", tz="America/New_York")
      }
    }

    absmindate <- Sys.Date() - 1200
    absmaxdate <- Sys.Date()
    # reactive list instead of update
    list(dateRange=dateRange(),start=startdate, end=enddate-1, min=absmindate, max=absmaxdate)    
  })

  observe({
    print("date range changed!")
    d <- regionRedraw()
  })

  output$timeseries <- renderPlotly({
    rangestart <- dateRange()[1]
    rangeend <- dateRange()[2]
    diff_in_days = as.numeric(difftime(rangeend, rangestart, units = "days"))
    tm <- seq(0, diff_in_days, by = 10)
    x <- rangeend - tm
    y <- rnorm(length(x))

    p <- plot_ly(x = ~x
                 , y = ~y
                 , type = "scatter"
                 , mode = "markers"
                 , text = paste(tm, "days from today")
                 , source = "timeseries")
  })
  # return list to update date input later
  return(reactive(regionRedraw()))
}

示例应用：

library(shiny)
library(plotly)
source("mod.R", local = TRUE)
ui <- shinyUI(fluidPage(
  chartTimeseriesUI("myseries")
  , dateRangeInput("dateRange", "Select Date Range:"
                   , start = Sys.Date() - 600
                   , end = Sys.Date()-1
                   , min = Sys.Date() - 1200
                   , max = Sys.Date()
  )
))

server <- shinyServer(function(input, output, session) {
  # receive return
  z <- callModule(chartTimeseries, id = "myseries", 
                  reactive(input$dateRange))

  observe({
    vals <- z()
    # update date
    updateDateRangeInput(session, "dateRange",start=vals$start,end=vals$end)
  })


})

shinyApp(ui = ui, server = server)