ggplot2 in shiny, change then reload image/plot without completely recreating it

Question

I'm making an app with shiny which will allow users to click to select points on an image. I'm using ggplot2 to display the points as they're selected, as red dots on the image.

I have this working pretty close to the way I want, except that every time the user clicks a new point, the entire image gets reloaded*. Ideally, I'd be re-plotting the data each click, but not reloading the entire image.

My question is, is it possible to have the plot points reload reactively, but leave the background image alone (since it won't change between clicks)?

My actual app is more involved than this, but here is my best attempt at a minimal reproducible example of the issue I'd like to address (note you'll need to adjust image.file to point to a jpg file on your machine in order to run this; I don't know how to make the image itself reproducible, sorry):

library( ggplot2 )
library( jpeg )
library( grid )
library( shiny )

#### pre-run setup ####

# set up a function for loading an image file as a grob
grob_image <- function( file ) {
    grid::rasterGrob( jpeg::readJPEG( file ), interpolate = TRUE )
}

# initiate a ggplot theme for use in plotting
# (just getting rid of everything so we only see the image itself)
theme_empty <- theme_bw()
theme_empty$line <- element_blank()
theme_empty$rect <- element_blank()
theme_empty$strip.text <- element_blank()
theme_empty$axis.text <- element_blank()
theme_empty$plot.title <- element_blank()
theme_empty$axis.title <- element_blank()

# set the image input file
image.file <- "session2_ebbTriggerCountMap.jpg"

#### UI ####
ui <- fluidPage(

    # display the image, with any click-points
    fluidRow(
        plotOutput("plot",
                   click = "image_click"
        )
    )

)


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

    # initialise a data.frame for collecting click points
    data.thisimage <- data.frame( x = rep( NA_real_, 100L ), y = rep( NA_real_, 100L ) )

    # initalise the plot (this is the image on which to put any points we get)
    # the `geom_blank` here is to set up the x and y axes as per the width and height of the image
    img <- grob_image( image.file )
    base <- ggplot() +
        geom_blank( data = data.frame( x = c( 0, dim( img$raster )[2] ), y = c( 0, dim( img$raster )[1] ) ),
                    mapping = aes( x = x, y = y )
        ) +
        theme_empty +
        annotation_custom( grob = img )

    # plot the image
    output$plot <- renderPlot( {
        base
    } )

    #### click action ####
    # watch for a mouse click (point selected on the plot)
    observeEvent( input$image_click, {

        # add a row of data to the data frame
        data.thisimage[ which( is.na( data.thisimage$x ) )[1L], ] <<- c(
            input$image_click$x, input$image_click$y
        )

        # re-render the plot with the new data
        output$plot <<- renderPlot( {
            base +
                geom_point( data = data.thisimage[ !is.na( data.thisimage$x ), ],
                            mapping = aes( x = as.numeric( x ), y = as.numeric( y ) ),
                            colour = "red" )
        } )

    } )
}
shinyApp(ui, server)

Since the image gets reloaded with every mouse click, I'm anticipating problems with reactivity of the UI, CPU load, and data transfer load. Is there any way to alleviate that?

* it's probably obvious from the code itself, but I've proved it to myself by watching CPU load while clicking over and over again with a large-ish image loaded.

NOTE the closest I could find to my problem was this SO question. Unfortunately it doesn't resolve the issue of reloading the image, only speeding up the rendering of data points, which is not my problem here. Update large plots in Shiny without Re-Rendering

Answer 1

I'll try first to suggest a shorter version of the code, to make sure which part is the heavy one.

• I took base <- ggplot() out of the server as it depends on static values, and could be executed once.

• I created xy_coord() capture the click x-y coordinates.

• I used shinySignals::reducePast to add the values to a dataframe xy_click(). Note: shinySignals is still under development, so you can write the function yourself if you would like.

• Now, I assume your problem is with having base in renderPlot, right?

  output$plot <- renderPlot({ base + geom_point(...) })

In the Updated Solution :

• In the UI, I created two divs on top of each other inside div "container", the bottom for the jpeg image and 2nd for the points.

• I plotted the jpeg image once at the bottom output$plot

• I used the click optionclick="image$click" the 2nd plot output$plot1, which will be rendered every time, because it is on the top.

• I used bg="transparent" option to have the image visible in the background.

EXTRA

You could even avoid using output$plot <- renderPlot(...) by moving the image to www folder in the app folder AND embedding the image in the first div using tags$img

| shinyApp/
    | app.R
| www/
    | survey.jpg

NOTE: This should work in case of perfect alignment of both image and plot2, I haven't tested intensively, but i tried a couple of examples.

---

Updated Solution

library(ggplot2)
library(jpeg)
library(grid)
library(shiny)

#### pre-run setup ####

# initiate a ggplot theme for use in plotting
# (just getting rid of everything so we only see the image itself)
theme_empty <- theme_bw()
theme_empty$line <- element_blank()
theme_empty$rect <- element_blank()
theme_empty$strip.text <- element_blank()
theme_empty$axis.text <- element_blank()
theme_empty$plot.title <- element_blank()
theme_empty$axis.title <- element_blank()

# set the image input file
image.file <- "www/survey.jpg"

img <- jpeg::readJPEG(image.file)

## set up a function for loading an image file as a grob ---------------------
# grob_image <- function(file) {
#   grid::rasterGrob( jpeg::readJPEG(file), interpolate = TRUE )
# }

## load the image as a a grob ---------------------
# img <- grob_image(image.file)

#### UI ####
ui <- fluidPage(

  # Overlapping images in 2 divs inside a "container"
  fluidRow(
    div(id="container",
        height = dim(img)[1],
        width = dim(img)[2],
        style="position:relative;",
        div(tags$img(src='survey.jpg',
                     style=paste0("width:",dim(img)[2],";height:",dim(img)[2],";")),
          # plotOutput("plot",
          #              height = dim(img)[1],
          #              width = dim(img)[2],
          #              click = "image_cl1"),
            style="position:absolute; top:0; left:0;"),
        div(plotOutput("plot1",
                       height = dim(img)[1],
                       width = dim(img)[2],
                       click = "image_click"),
            style="position:absolute; top:0; left:0;")
    )
  )
)

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

  ## get clicked point coordinates -----------------------
  xy_coord <- reactive(c(input$image_click$x,input$image_click$y))

  ## add the new points to the dataframe -----------------
  xy_clicks <- shinySignals::reducePast(xy_coord,
                                        function(x,y){
                                          df <- x
                                          nn <- nrow(df)

                                          # add values in case of click
                                          if(length(y)>0){
                                            df[nn+1,1 ] <- y[1]
                                            df[nn+1,2 ] <- y[2]
                                          }
                                          return(df)
                                        },
                                        init=data.frame(x_coord=numeric(0),
                                                        y_coord=numeric(0)))

  ## render plot of the jpeg image --------------------------------------
  # output$plot <- renderPlot({
  #   ggplot()+
  #     geom_blank(data = data.frame(x = c(0, dim(img$raster)[2])
  #                                  , y = c(0, dim(img$raster)[1])),
  #                mapping = aes(x = x, y = y))+
  #     theme_empty +
  #     annotation_custom(grob = img)
  # })

  # alternative for plot of the jpeg image
  # output$plot <- renderPlot({
  #   # plot_jpeg("survey.jpg")
  # })


  ## re-render the plot with the new data -------------------------
  output$plot1 <- renderPlot({
    ggplot() +
      geom_blank(data = data.frame(x = c(0,dim(img)[2])
                                   ,y = c(0,dim(img)[1])),
                 mapping = aes(x = x,
                               y = y))+
      theme_empty+
      geom_point(data = xy_clicks(),
                 mapping = aes(x = x_coord,
                               y = y_coord),
                 colour = "red")+
      coord_cartesian(xlim = c(0,dim(img)[2]),
                      ylim= c(0,dim(img)[1]))

  },
  bg="transparent")

}


## uncomment and add verbatimTextOutput("txt") in UI to see the xy_clicks() dataframe
# output$txt <- renderPrint(xy_clicks())

# Run the application 
shinyApp(ui = ui, server = server)

---

My version of the original code

library(ggplot2)
library(jpeg)
library(grid)
library(shiny)

#### pre-run setup ####

# set up a function for loading an image file as a grob
grob_image <- function( file ) {
  grid::rasterGrob( jpeg::readJPEG( file ), interpolate = TRUE )
}

# initiate a ggplot theme for use in plotting
# (just getting rid of everything so we only see the image itself)
theme_empty <- theme_bw()
theme_empty$line <- element_blank()
theme_empty$rect <- element_blank()
theme_empty$strip.text <- element_blank()
theme_empty$axis.text <- element_blank()
theme_empty$plot.title <- element_blank()
theme_empty$axis.title <- element_blank()

# set the image input file
image.file <- "survey.jpg"


## initalise the plot (this is the image on which to put any points we get)
# the `geom_blank` here is to set up the x and y axes as per the width and height of the image 
img <- grob_image(image.file)

## create base plot -----------------------
base <- ggplot() +
  geom_blank(data = data.frame(x = c(0, dim( img$raster )[2])
                                 , y = c(0, dim( img$raster )[1])),
              mapping = aes(x = x, y = y)
  ) +
  theme_empty +annotation_custom(grob = img)


#### UI ####
ui <- fluidPage(

  # display the image, with any click-points
  fluidRow(
    plotOutput("plot",
               height = dim( img$raster )[1],
               width = dim( img$raster )[2],
               click = "image_click"
    )
  )
)

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


  ## get clicked point coordinates -----------------------
  xy_coord <- reactive(c(input$image_click$x,input$image_click$y))

  ## add the new points to the dataframe -----------------
  xy_clicks <- shinySignals::reducePast(xy_coord,
                                        function(x,y){
                                          df <- x
                                          nn <- nrow(df)

                                          # add values in case of click
                                          if(length(y)>0){
                                            df[nn+1,1 ] <- y[1]
                                            df[nn+1,2 ] <- y[2]
                                          }

                                          return(df)
                                        },
                                        init=data.frame(x_coord=numeric(0),
                                                        y_coord=numeric(0)))


  ## re-render the plot with the new data -------------------------
  output$plot <- renderPlot({
    base +
      geom_point(data = xy_clicks(),
                 mapping = aes(x = x_coord, y = y_coord),
                 colour = "red")
  })

  ## uncomment and add verbatimTextOutput("txt") in UI to see the xy_clicks() dataframe
  # output$txt <- renderPrint(xy_clicks())
}

# Run the application 
shinyApp(ui = ui, server = server)