Избегать двойного обновления сюжета в блестящем

В блестящем сюжете я пытаюсь выделить точки, соответствующие точке щелчка (на основе nearPoints() и нажмите).

Это вроде работы. Тем не менее, реактивные части блестящего приложения обновляются дважды, а вторая итерация, по-видимому, очищает информацию с щелчком.

Как я могу избежать второго обновления приложения?

Вот MWE:

library("Cairo")
library("ggplot2")
library("shiny")

ui <- fluidPage(
  fluidRow(
    titlePanel('Phenotype Plots')
  ),

  fluidRow(
    uiOutput("plotui")
  ),

  hr(),

  fluidRow(

    wellPanel(
      h4("Selected"),
      tableOutput("info_clicked")
      ##dataTableOutput("info_clicked") ## overkill here
    )
  )
)


server <- function(input, output, session) {

  selected_line <-  reactive({
    nearPoints(mtcars, input$plot_click,
               maxpoints = 1,
               addDist = TRUE)
  })

  output$plotui <- renderUI({
      plotOutput("plot", height=600,
        click = "plot_click"
      )
    })

  output$plot <- renderPlot({

    p <- ggplot(mtcars) +
      facet_grid(am ~ cyl) +
      theme_bw() +
      geom_point(aes(x=wt, y=mpg))

    sline <- selected_line()
    if (nrow(sline) > 0) {
      p <- p +
        geom_point(aes(x=wt, y=mpg),
                   data=mtcars[mtcars$gear == sline$gear,],
                   colour="darkred",
                   size=1)
    }

    p

  })

  ##output$info_clicked <- renderDataTable({
  output$info_clicked <- renderTable({
    res <- selected_line()
    ## datatable(res)
    res
  })

}

shinyApp(ui, server)

library("Cairo") library("ggplot2") library("shiny") ui <- fluidPage( fluidRow( titlePanel('Phenotype Plots') ), fluidRow( uiOutput("plotui") ), hr(), fluidRow( wellPanel( h4("Selected"), tableOutput("info_clicked") ##dataTableOutput("info_clicked") ## overkill here ) ) ) server <- function(input, output, session) { ## CHANGE HERE ## Set up buffert, to keep the click. click_saved <- reactiveValues(singleclick = NULL) ## CHANGE HERE ## Save the click, once it occurs. observeEvent(eventExpr = input$plot_click, handlerExpr = { click_saved$singleclick <- input$plot_click }) ## CHANGE HERE selected_line <- reactive({ nearPoints(mtcars, click_saved$singleclick, ## changed from "input$plot_click" to saved click. maxpoints = 1, addDist = TRUE) }) output$plotui <- renderUI({ plotOutput("plot", height=600, click = "plot_click" ) }) output$plot <- renderPlot({ p <- ggplot(mtcars) + facet_grid(am ~ cyl) + theme_bw() + geom_point(aes(x=wt, y=mpg)) sline <- selected_line() if (nrow(sline) > 0) { p <- p + geom_point(aes(x=wt, y=mpg), data=mtcars[mtcars$gear == sline$gear,], colour="darkred", size=1) } p }) ##output$info_clicked <- renderDataTable({ output$info_clicked <- renderTable({ res <- selected_line() ## datatable(res) res }) } shinyApp(ui, server)

Ответ 1