evitare doppio aggiornamento della trama in lucido

Question

In una trama lucida sto cercando di evidenziare i punti corrispondenti a un punto cliccato (basato su nearPoints() e clic).

Questo tipo di lavori. Tuttavia, le parti reattive dell'app lucida vengono aggiornate due volte e la seconda iterazione sembra cancellare le informazioni su cui si fa clic.

Come posso evitare il secondo aggiornamento dell'app?

Ecco la 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) 

Answer 1

finalmente trovato una soluzione per evitare la doppia aggiornamento sul click in Shiny: cattura click ad un reactiveValue(), utilizzando il observeEvent(). Sembra che lavori anche sul mio progetto e anche sul tuo MWE. Vedere la sezione sul codice aggiornato di seguito.

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)