I'd like to elaborate on the accepted answer to this question.
I'm looking at improving the minimal shiny app below (extracted from the accepted answer) with the following features:
- 1) draw the rectangle + a text label. The label comes from R (
input$foo
), e.g., from a dropdown. To avoid the edge cases where the labels fall outside the images, labels should be placed inside their rectangles. - 2) use a different color for the rectangles and their labels depending on the label
- 3) ability for the user to delete a rectangle by double-clicking inside it. In the case of multiple matches (overlap, nested), the rectangle with the smallest area should be deleted.
Brownie points for 1): the dropdown could appear next to the cursor like is done here (code here). If possible, the dropdown list should be passed from server.R and not be fixed/hardcoded. The reason is that depending on the user input, a different dropdown could be shown. E.g., we might have one dropdown for fruits c('banana','pineapple','grapefruit')
, one dropdown for animals c('raccoon','dog','cat')
, etc.
# 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)