Browser-friendly way of drawing rectangles on top of image R Shiny

Question

I have written a shiny app that allows the user to draw rectangles on top of an image (minimal reproducible example below).

The problem with my current approach is that every time a rectangle is added, a new image is created, written to disk, and rendered (sent to the user's browser). This takes quite some time, and becomes really annoying when the Internet connection is slow.

Is there any way to display the rectangles on top of the image directly in the browser, without modifying the image on the server side? The only thing I need to ensure is that the browser sends back to the server the rectangles coordinates over the plot.

A good example of what I'm looking for (in JavaScript): https://kyamagu.github.io/bbox-annotator/demo.html I know JavaScript can be embedded in a Shiny app through a widget, if no one proposes an easier solution, that's what I'll do.

library(shiny)
library(png)
library(RCurl)

myurl = 'https://raw.githubusercontent.com/Tixierae/deep_learning_NLP/master/CNN_IMDB/cnn_illustration.png'
my_img = readPNG(getURLContent(myurl))
img_height = dim(my_img)[1]
img_width = dim(my_img)[2]

server = function(input, output) {

    observe({

        outfile = tempfile(tmpdir='./', fileext='.png')

        png(filename=outfile,width=img_width,height=img_height)

        par(mar=c(0,0,0,0),xaxs='i', yaxs='i')
        plot(NA,xlim=c(0,img_width),ylim=c(0,img_height))
        rasterImage(my_img,0,0,img_width,img_height)

        if (!is.null(input$image_brush)){
            b_in = lapply(input$image_brush,as.numeric)
            if (!is.null(b_in$xmin)){
                rect(b_in$xmin,img_height-b_in$ymax,b_in$xmax,img_height-b_in$ymin,border='green',lwd=5)
            }
        }

        dev.off()

        output$my_image = renderImage({
            list(
                src = outfile,
                contentType = 'image/png',
                width = img_width,
                height = img_height,
                alt = ''
            )
        },deleteFile=TRUE)

        output$image = renderUI({
            imageOutput('my_image',
                height = img_height,
                width = img_width,
                click = 'image_click',
                dblclick = dblclickOpts(
                    id = 'image_dblclick'
                ),
                hover = hoverOpts(
                    id = 'image_hover'
                ),
                brush = brushOpts(
                    id = 'image_brush',resetOnNew=TRUE,delayType='debounce',delay=100000
                )
            )
        })
    })
}

ui = bootstrapPage(
    uiOutput('image')
)

shinyApp(ui=ui, server=server)

Answer 1

Here's a JS option based entirely on this answer.

# JS and CSS modified from: https://stackoverflow.com/a/17409472/8099834
css <- "
    #canvas {
        width:2000px;
        height:2000px;
        border: 10px solid transparent;
    }
    .rectangle {
        border: 5px solid #FFFF00;
        position: absolute;
    }
"

js <- 
"function initDraw(canvas) {
    var mouse = {
        x: 0,
        y: 0,
        startX: 0,
        startY: 0
    };
    function setMousePosition(e) {
        var ev = e || window.event; //Moz || IE
        if (ev.pageX) { //Moz
            mouse.x = ev.pageX + window.pageXOffset;
            mouse.y = ev.pageY + window.pageYOffset;
        } else if (ev.clientX) { //IE
            mouse.x = ev.clientX + document.body.scrollLeft;
            mouse.y = ev.clientY + document.body.scrollTop;
        }
    };

    var element = null;    
    canvas.onmousemove = function (e) {
        setMousePosition(e);
        if (element !== null) {
            element.style.width = Math.abs(mouse.x - mouse.startX) + 'px';
            element.style.height = Math.abs(mouse.y - mouse.startY) + 'px';
            element.style.left = (mouse.x - mouse.startX < 0) ? mouse.x + 'px' : mouse.startX + 'px';
            element.style.top = (mouse.y - mouse.startY < 0) ? mouse.y + 'px' : mouse.startY + 'px';
        }
    }

    canvas.onclick = function (e) {
        if (element !== null) {
           var coord = {
               left: element.style.left,
               top: element.style.top,
               width: element.style.width,
               height: element.style.height
            };
            Shiny.onInputChange('rectCoord', coord);
            element = null;
            canvas.style.cursor = \"default\";
        } else {
            mouse.startX = mouse.x;
            mouse.startY = mouse.y;
            element = document.createElement('div');
            element.className = 'rectangle'
            element.style.left = mouse.x + 'px';
            element.style.top = mouse.y + 'px';
            canvas.appendChild(element);
            canvas.style.cursor = \"crosshair\";
        }
    }
};
$(document).on('shiny:sessioninitialized', function(event) {
    initDraw(document.getElementById('canvas'));
});
"

library(shiny)

ui <- fluidPage(
  tags$head(
      tags$style(css),
      tags$script(HTML(js))
  ),
  fluidRow(
      column(width = 6, 
             # inline is necessary
             # ...otherwise we can draw rectangles over entire fluidRow
             uiOutput("canvas", inline = TRUE)),
      column(
          width = 6,
          verbatimTextOutput("rectCoordOutput")
          )
  )
)

server <- function(input, output, session) {
    output$canvas <- renderUI({
        tags$img(src = "https://www.r-project.org/logo/Rlogo.png")
    })
    output$rectCoordOutput <- renderPrint({
        input$rectCoord
    })

}

shinyApp(ui, server)