Блог

Я борюсь с прослушивателем событий plotly, который, кажется, активен после предполагаемого момента. У меня есть два метода выбора диапазона дат — a sliderInput и plotlyOutput график. В то время как Shiny reactivity и plotly event_register, как правило, отвечают по назначению, plotly event_register также срабатывает в нежелательный момент — когда пользователь делает selectInput выбор после нажатия кнопки для сброса после более раннего plotlyOutput выбора диапазона перетаскивания.

Приложение ниже воспроизводит проблему. Помощь очень ценится.

 require(tidyverse)
require(shiny)
require(plotly)

d = as_tibble(EuStockMarkets) %>% mutate(date = Sys.Date()   (-1860:-1)) %>% 
  pivot_longer(-date, names_to = 'market')

ui = fluidPage(
  sidebarPanel(width = 3,
               h5('Persistent sparkline to show full date range'),
    plotOutput("sparkline", height = '100px'),
    sliderInput('date_range', 'Date range', min = min(d$date), max = max(d$date),
                value = range(d$date), step = 1, timeFormat = '%d %b %y'),
    actionButton('reset_date_range', 'Reset sliderInput to full range', style='height: 25px; padding: 2px 5px;'),
    hr(),
    selectInput('market', 'Market', choices = unique(d$market), selected = 'DAX'),
    h4('Steps to reproduce the problem:'),
    p('1. Drag a date range in the big (plotly) plot. This will apply to sliderInput and main plot will update as intended.'),
    p('2. Click the button to reset the range.'),
    p('3. Select a new market.  The sliderInput will revert to the last plotly plot's drag range despite the reset.'),
    h5('Plotly event_register response:'),
    verbatimTextOutput("brushed")
  ),
  mainPanel(width = 9, plotlyOutput('plot', height='80vh'))
)

server = function(input, output, session) {
  
  r = reactiveValues() # my app requires a reactive data object
  
  observeEvent(input$market, {
    r$dat = d %>% filter(market == local(input$market))  # filter reactive data

    # Sparkline plot
    output$sparkline = renderPlot({
      d %>% filter(market == input$market) %>% 
        qplot(date, value, label = round(value), geom = 'line', data = .)  
        geom_text(data = function(x){ filter(x, value %in% range(value))}, size = 4)  
        theme_void()   scale_y_continuous(expand = c(0.2, 0.2))
    }, bg="transparent")
    
    # Plotly timeline plot
    output$plot = renderPlotly({
      p = r$dat %>% qplot(date, value, data = ., geom = 'line')   theme_minimal()
      ggplotly(p) %>% layout(dragmode = "select") %>% event_register("plotly_brushed")
    })
    
    output$brushed <- renderPrint({
      e_dat = event_data("plotly_brushed")
      if(length(na.omit(e_dat$x)) == 2){
        sliderRange <<- as.Date(e_dat$x, origin='1970-01-01')
        updateSliderInput(session, 'date_range', value = sliderRange)
        sliderRange <<- NULL # test to ensure e_dat$x isn't persisting somehow
      }
      print(e_dat)
    })
    
  })
  
  # update reactive r$dat if the slider used
  observeEvent(input$date_range, {
    r$dat = d %>% filter(market == local(input$market), date >= input$date_range[1], date <= input$date_range[2])
  })
  
  # reset date selection
  observeEvent(input$reset_date_range, {
    date_range = range(d$date, na.rm = TRUE)
    updateSliderInput(session, 'date_range', min = date_range[1], max = date_range[2], value = date_range)
  })
  
}

shinyApp( ui = ui, server = server)
  

Ошибка новичка .. мне output$brushed <- renderPrint({ ... }) просто нужно выйти за пределы observeEvent(input$market, ...) предложения.