R中保持部件同步互动情节闪亮

Question

我有一个RShiny应用程序，我希望能够与“互动”，以更新的互动情节像刷过的情节（https://shiny.rstudio.com/articles/plot-interaction.html），并采用了滑盖部件

我遇到的问题是笔刷更新范围，然后绘制绘图，然后范围更新滑块，然后滑块更新绘图。这意味着它正试图绘制情节的两倍，但在更糟糕的情况下，它可能会导致一个无限循环太

这里是一个小例子代码

library(shiny) 

shinyApp(
    ui = fluidPage(
     titlePanel("Test"), 
     sidebarLayout(
     sidebarPanel(
      p("This app can adjust plot with slider or with brush, but it plots the figure twice when the interactive brush is used. How to fix?"), 
      uiOutput("sliderRange") 
     ), 
     mainPanel(
      plotOutput("distPlot", 
      brush = brushOpts(
       id = "plot_brush", 
       resetOnNew = T, 
       direction = "x" 
      ) 
     ) 
     ) 
    ) 
    ), 
    server = function(input, output) { 
     ranges <- reactiveValues(xmin = 0, xmax = 10) 
     observeEvent(input$plot_brush, { 
      brush <- input$plot_brush 
      if (!is.null(brush)) { 
       ranges$xmin <- brush$xmin 
       ranges$xmax <- brush$xmax 
      } 
     }) 
     observeEvent(input$sliderRange, { 
      ranges$xmin <- input$sliderRange[1] 
      ranges$xmax <- input$sliderRange[2] 
     }) 

     output$sliderRange <- renderUI({ 
      sliderInput("sliderRange", "Range", min = 0, max = 100, value = c(ranges$xmin, ranges$xmax), step = 0.001) 
     }) 

     output$distPlot <- renderPlot({ 
      print('Plotting graph') 
      s = ranges$xmin 
      e = ranges$xmax 
      plot(s:e) 
     }) 
    } 
) 

Answer 1

最好将简化事件流从刷更新滑块，然后从滑块范围：

shinyApp(
    ui = fluidPage(
     titlePanel("Test"), 
     sidebarLayout(
     sidebarPanel(
      sliderInput("sliderRange", "Range", min = 0, max = 100, value = c(0,100)) 
     ), 
     mainPanel(
      plotOutput("distPlot",brush = brushOpts(
         id = "plot_brush", 
         resetOnNew = T, 
         direction = "x" 
        ) 
     )))), 
    server = function(input, output, session) { 
     ranges <- reactiveValues(xmin = 0, xmax = 10) 

     observeEvent(input$plot_brush, { 
     brush <- input$plot_brush 
     if (!is.null(brush)) { 
      updateSliderInput(session, "sliderRange", value=c(brush$xmin,brush$xmax)) 
     } 
     }) 

     observeEvent(input$sliderRange, { 
      ranges$xmin <- input$sliderRange[1] 
      ranges$xmax <- input$sliderRange[2] 
     }) 

     output$distPlot <- renderPlot({ 
     print('Plotting graph') 
     s = ranges$xmin 
     e = ranges$xmax 
     plot(s:e) 
     }) 
    } 
) 

如果这是不可能的应用程序，您可以使用此解决办法，以避免重新绘制：从滑块更新范围之前，你可以检查它是否已被修改。如果它刚刚被刷子修改过，它会相同（或非常接近）。那么你不需要再次更新它，并且绘图不会被绘制：

observeEvent(input$sliderRange, { 
    if(abs(ranges$xmin - input$sliderRange[1])>0.1 || # Compare doubles 
     abs(ranges$xmax - input$sliderRange[2])>0.1) # on small difference 
     { 
     ranges$xmin <- input$sliderRange[1] 
     ranges$xmax <- input$sliderRange[2] 
     } 
    })