unexpected behaviour when clicking on a scaled image

[pieterprovoost]

System details

Browser Version: Google Chrome Version 87.0.4280.88 (Official Build) (x86_64), high DPI screen

Output of sessionInfo():

R version 4.0.2 (2020-06-22)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS  10.16

Matrix products: default
LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib

locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] shiny_1.5.0.9006

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.5           digest_0.6.27        later_1.1.0.1        mime_0.9            
 [5] R6_2.5.0             jsonlite_1.7.2       lifecycle_0.2.0      xtable_1.8-4        
 [9] magrittr_2.0.1       cachem_0.0.0.9000    rlang_0.4.10         promises_1.1.1.9001 
[13] jquerylib_0.1.3      bslib_0.2.3.9000     ellipsis_0.3.1       tools_4.0.2         
[17] tinytex_0.24         httpuv_1.5.4         xfun_0.15            fastmap_1.0.1       
[21] compiler_4.0.2       htmltools_0.5.0.9003 sass_0.2.0.9005  

Example application

library(shiny)

shinyApp(
  ui = basicPage(
    fluidRow(
      column(width = 6, imageOutput("image", click = "image_click")),
      column(width = 6, verbatimTextOutput("image_clickinfo"))
    )
  ),
  server = function(input, output, session) {
    output$image <- renderImage({
      list(
        src = "test_1000.png",
        contentType = "image/png",
        width = "100%"
      )
    })
    output$image_clickinfo <- renderPrint({
      str(input$image_click)
    })
  }
)

Test image: test_1000.png

Describe the problem in detail

The example application loads an existing image into an imageOutput and adds a click handler. This works fine for smaller images, but when the image is larger than the DOM element, clicks are only registering in the top left part of the image. In the example below, a 1000 by 1000 pixel image is loaded into a 610 CSS pixels wide element. Clicking on the top left crosshairs will correctly return (200, 200) in image coordinates, so the fact that the image is scaled is taken into account. However, clicking on the bottom right crosshairs does not work as its location in image coordinates (800, 800) exceeds the size of the DOM element (610).

I fiddled around with the code a bit and managed to fix my problem by using img.naturalWidth and img.naturalHeight here, but that breaks the official example.

[dcaud]

Does using something like image_click$coords_image$x and image_click$coords_image$y fix this?

[sjmgarnier]

Has this issue been addressed? Or is there a workaround for it? I have the same problem with my app and I can reproduce the issue with the example application provided by @pieterprovoost

[dcaud]

Here's another repro of the problem, which is important because you can't capture clicks when you account for pixel ratios.

library(shiny)
library(magick)

# Define UI for application
ui <- fluidPage(
  titlePanel("ImageMagick Wizard Rendering"),
  sidebarLayout(
    sidebarPanel(
      helpText("Compare the wizard rendering with and without reference to pixel ratio."),
      verbatimTextOutput("click_info_no_pixelratio"),
      verbatimTextOutput("click_info_pixelratio")
    ),
    mainPanel(
      h3("Without Pixel Ratio Reference"),
      imageOutput("image_no_pixelratio", click = "click_no_pixelratio"),
      h3("With Pixel Ratio Reference - NO CLICK CAPTURED WHEN CLICKING LOWER RIGHT"),
      imageOutput("image_pixelratio", click = "click_pixelratio")
    )
  )
)

# Define server logic
server <- function(input, output, session) {
  output$image_no_pixelratio <- renderImage({
    # Read image dimensions from client
    width <- session$clientData$output_image_no_pixelratio_width
    height <- session$clientData$output_image_no_pixelratio_height

    # Load the wizard image
    img <- image_read("wizard:")
    original_width <- image_info(img)$width
    original_height <- image_info(img)$height

    # Maintain aspect ratio
    aspect_ratio <- original_width / original_height
    if (width / height > aspect_ratio) {
      width <- height * aspect_ratio
    } else {
      height <- width / aspect_ratio
    }

    img <- image_resize(img, paste0(width, "x", height))

    # Save the image without pixel ratio reference
    img_path_no_pixelratio <- tempfile(fileext = ".jpeg")
    image_write(img, path = img_path_no_pixelratio)

    list(src = img_path_no_pixelratio,
         width = width,
         height = height,
         contentType = 'image/jpeg',
         alt = "Wizard without pixel ratio")
  }, deleteFile = TRUE)

  output$image_pixelratio <- renderImage({
    # Read image dimensions and pixel ratio from client
    width <- session$clientData$output_image_pixelratio_width
    height <- session$clientData$output_image_pixelratio_height
    pixelratio <- session$clientData$pixelratio

    # Load the wizard image
    img <- image_read("wizard:")
    original_width <- image_info(img)$width
    original_height <- image_info(img)$height

    # Maintain aspect ratio
    aspect_ratio <- original_width / original_height
    if (width / height > aspect_ratio) {
      width <- height * aspect_ratio
    } else {
      height <- width / aspect_ratio
    }

    img <- image_resize(img, paste0(width * pixelratio, "x", height * pixelratio))

    # Save the image with pixel ratio reference
    img_path_pixelratio <- tempfile(fileext = ".jpeg")
    image_write(img, path = img_path_pixelratio)

    list(src = img_path_pixelratio,
         width = width,
         height = height,
         contentType = 'image/jpeg',
         alt = "Wizard with pixel ratio")
  }, deleteFile = TRUE)

  # Display click coordinates without pixel ratio reference
  output$click_info_no_pixelratio <- renderPrint({
    if (!is.null(input$click_no_pixelratio)) {
      coords <- input$click_no_pixelratio
      cat("Click coordinates without pixel ratio reference:\n")
      cat("x:", coords$x, "y:", coords$y, "\n")
    }
  })

  # Display click coordinates with pixel ratio reference
  output$click_info_pixelratio <- renderPrint({
    if (!is.null(input$click_pixelratio)) {
      coords <- input$click_pixelratio
      pixelratio <- session$clientData$pixelratio
      if (is.null(pixelratio)) {
        pixelratio <- 1
      }
      cat("Click coordinates with pixel ratio reference:\n")
      cat("x:", coords$x / pixelratio, "y:", coords$y / pixelratio, "\n")
    }
  })
}

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

[lachlansimpson]

This was mentioned in internal support ticket 107146.