R Shiny brush zoom a dynamically sized image

Question

I have been looking at advanced interactive plots in Shiny and I am struggling with how to accomplish a brush and double click zoom on an image, as opposed to a plot. To further complicate matters, I am showing an image and a plot side by side in the Rshiny widget, so the image size is dynamic to fit. I can't figure out how to map the pixel coordinates to the resized xy coords for the brush events. Is there some way to get the resize ratio inside renderImage. The app is inside a function and takes a Seurat Object for plotting and renders it next to a reference image (which I need to zoom in on).

#' Dot Plots of snRNAseq Marker Genes For Neuronal Celltypes
#'
#' @param sc Seurat Object to examine
#' @param map reference figures from the Yao etal. 2021. DOI: 10.1016/j.cell.2021.04.021
#' | map | neighborhood | desc |
#' | --- | --- | --- |
#' | yao_gab_CGE | CGE | GABAergic(inhibitory) neurons from the caudal ganglionic eminence |
#' | yao_gab_MGE | MGE | GABAergic(inhibitory) neurons from the medial ganglionic eminence |
#' | yao_glu_L23 | L2/3 IT | Layer 2/3 glutamatergic intratelencephalic neurons|
#' | yao_glu_L23456 | L4/5/6 IT Car3, L2/3 IT | Layer 4/5/6 glutamatergic intratelencephalic neurons |
#' | yao_glu_npctl6b | NP/CT/L6b | Corticothalamic, near-projecting and Layer 6b neurons |
#' | yao_glu_pt | PT | Pyramidal tract neurons & layer 4 retrosplenial, anterior cingulate neurons |
#' | yao_glu_top | All Glu | top marker gene for all subclasses of glutamatergic neurons |
#' | yao_glu_fallback | All Glu | general backup map for glutamatergic neurons when all else fails |
#'
#' @return violin plots for seurat object alongside paper reference image
#' @export
#'
#' @examples
plot_dots = function(sc, map=c("yao_gab_CGE", "yao_gab_MGE", "yao_glu_L23", 
                               "yao_glu_L23456", "yao_glu_npctl6b", "yao_glu_pt",
                               "yao_glu_top", "yao_glu_fallback")) {
  DefaultAssay(sc) = "RNA"
  # only non-zero rows or error: invalid 'times' argument
  sc_names = rownames(sc)[rowSums(sc) > 0] 

  # known marker genes for papers
  yao_gab_CGE = c("Adarb2", "Prox1", "Lhx6", "Rxfp3", "Ntf3", "Lamp5", "Pdlim5",
                  "Ndnf", "Rxfp1", "Dock5", "Lsp1", "Slc35d3", "Jam2", "Egln3", 
                  "Fam19a1", "Npy2r", "Pax6", "Krt73", "Sncg", "Serpinf1", 
                  "Slc17a8", "Calcb", "Npffr1", "Ntng1", "Vip", "Pthlh", 
                  "Pcdh11x", "Cp", "Mybpc1", "Gpc3", "Slc5a7", "Cbln4", "Chat",
                  "Rspo1", "Lmo1", "Tmem176a", "Qrfpr", "Igfbp6")
  yao_glu_MGE = c("Sst", "Pvalb", "Sox6", "Rbp4", "Chodl", "Chrna2", "Crh", 
                  "Lmo1", "Ptprk", "Th", "Nts", "Myh8", "Rxfp3", "Etv1", 
                  "Calb2", "Nmbr", "Hpse", "Sfrp2", "Necab1", "Ctsc", "Id3", 
                  "Npffr1", "Adamtsl1", "Cxcr4", "Sln", "Cryba2", "Pde3a", 
                  "Npy2r", "Grem1", "Lpl", "Vipr2", "Ntf3", "Sntb1")
  yao_glu_npctl6b = c("Foxp2", "Tshz2", "Meis2", "Rasgrf2", "Vwc2l", "Sla2", 
                      "Grik1", "Gpc6", "Kcnip1", "Cbln2", "Ephb1", "Rprm", 
                      "Thsd7b", "Col5a1", "Nxph4", "Ccn2", "Cplx3", "Tmem255b",
                      "Nts", "Ddit4l", "Ly6g6e", "Rorb", "Nnat", "Cobll1", 
                      "Sema3c", "Nr2f2", "Nxph1", "Slc17a8", "Abi3bp", 
                      "Col12a1", "Syt6", "Clic5")
  yao_glu_pt = c("Lratd2", "Bcl6", "Slc30a3", "Tshz2", "Npnt", "Fn1", "Chrna6", 
                 "Tmem215", "Spc25", "Lypd1", "Tpbg", "Nrtn", "Erg", "Prph", 
                 "Qrfpr", "Stac", "Bmp5", "Samd3", "Lgr5", "Slco2a1", "Col8a1",
                 "Pvalb", "Cdh13", "Npsr1", "Pappa2", "Blnk", "Serpina3n", 
                 "Ndnf", "Dlk1", "Nnat", "Hpgd", "Chst9", "C1ql2", "Igfbp2", 
                 "Ctxn3", "Scnn1a", "Hsd11b1", "Ptgfr")
  yao_glu_fallback = c("Nxph3", "Tle4", "Cntnap4", "Hs3st5", "Thsd7b", "Sulf1", 
                       "Cryab", "Foxp2", "Rai14", "Sema5b", "Pou6f2", "Col19a1",
                       "Cplx3", "Ctgf", "Drd1", "Nxph4", "Galnt10", "Lypd6b", 
                       "Nhs", "Kcnv1", "Rims3", "Deptor", "Bok", "Kcnip1", 
                       "Grik1", "Stard5", "Cbln2", "Mcc", "Trpc3", "Rell1", 
                       "Pamr1", "Lrrc55", "Pou3f1", "Gprc5b", "Npr3", "Bcl6", 
                       "Chst8", "Gng7", "Sulf2", "Fezf2", "Etv1", "Bcl11b", 
                       "Parm1", "Crym", "Ntng1", "Bhlhe40", "Fras1", "Bhlhe22",
                       "Fam126a", "Iqgap2", "Syt17", "Ajap1", "Rtn4rl1", 
                       "Rtn4r", "Sntb2", "Ntng2", "Nos1", "Pde7b", "Lhx2", 
                       "Gpr88", "Otof", "Prkg2", "Thsd7a", "Synpr", "Cux2", 
                       "Slc30a3", "Cpne5", "Stxbp6")
  yao_glu_L23 = c("Cdh7", "Kit", "Pdlim1", "Npnt", "Plch1", "Fign", "Wfs1", 
                  "Prlr", "Cfap58", "Lef1", "Grik1", "Ndst4", "Trhr", "Stard8", 
                  "Dcn", "Cbln4", "Id4")
  yao_glu_L23456 = c("Otof", "Trhr", "Stard8", "Baz1a", "Cux2", "Rspo1", "Rorb",
                     "Etv1", "Fezf2", "Tshz2", "Foxo1", "Cdh9", "Rxfp1", 
                     "Sulf1", "Fst", "Osr1")
  micro = c("P2ry12", "Tmem119", "Gpr34", "Jun", "Olfml3", "Csf1r", "Hexb", 
            "Mertk", "Rhob", "Cx3Cr1", "Tgfbr1", "Tgfb1", "Mef2a", "Mafb", 
            "Jun", "Sall1", "Egr1", "Spp1", "Itgax", "Axl", "Lilrb4", "Clec7a",
            "Ccl2", "Csf1", "Apoe")
  astro = c("Gfap", "Stat3", "Smarca4", "Ntrk2", "Aldoc", "Aldoa", "Apoe", "C3",
            "Isg15", "Pou5f1", "Sox9", "Cst3", "Mt1", "Trpm3", "Gpc5", "S100b",
            "Sox9", "Rela", "Csf2ra", "Csf2rb", "Mafg", "Mat2a", "Dnmt3a", 
            "Gstm1", "Gstp1", "Gstp2", "Prdx6", "Gja1", "Aldh1l1", "Gfap", 
            "Aqp4", "Nfe2l2")

  # get list
  g = get(map)

  # plot side by side
  ui <- fluidPage(
    titlePanel(map),

    # dynamic image width
    tags$head(
      tags$style(type="text/css", 
                 "#myImg img {max-width: 100%; width: 100%; height: auto}"
      )
    ),

    fluidRow(
      column(6,
        imageOutput("myImg", click="myImg_click",
                    brush=brushOpts(id="myImg_brush", resetOnNew=T)),
        )
      ),
      column(6, plotOutput("dots")
      )
    )
  server <- function(input, output, session) {
    output$dots = renderPlot({
      DotPlot(sc, features=intersect(rev(g), rownames(sc))) + coord_flip()
    })
    
    # -------------------------------------------------------------------
    # Single zoomable plot (on left)
    ranges <- reactiveValues(x = NULL, y = NULL)
  
    output$myImg = renderImage({
      list(src=list.files(path=imgdir, pattern=map, full.names=T))
    }, deleteFile=F)
    
    # Somehow fetch the resize ratio? To map pixel coords to xy coords?

    # When a double-click happens, check if there's a brush on the plot.
    # If so, zoom to the brush bounds; if not, reset the zoom.
    observeEvent(input$myImg_click, {
      brush <- input$myImg_brush
      if (!is.null(brush)) {
        ranges$x <- c(brush$xmin, brush$xmax)
        ranges$y <- c(brush$ymin, brush$ymax)
  
      } else {
        ranges$x <- NULL
        ranges$y <- NULL
      }
    })
     # -------------------------------------------------------------------
    # graceful exit if closing the shiny window
    session$onSessionEnded(function() {
      stopApp()
      })
  }
  return(shinyApp(ui, server))

Answer 1

Turns out, in trying to create a more reproducible example, I came across a solution buried in the documentation for cowplot's draw_image. In combination with ggdraw you can define a gg object aligned to your picture. So at that point you can follow the standard zoom.R template and specify reactive ranges$x and ranges$y in ggdraw

# zoom.R
library(shiny)
library(ggplot2)
library(cowplot)

ui <- fluidPage(
  fluidRow(
    column(width = 6, 
      h4("Brush and double-click to zoom"),
      plotOutput("plot1", width="100%",
        dblclick = "plot1_dblclick",
        brush = brushOpts(
          id = "plot1_brush",
          resetOnNew = TRUE
        )
      )
    ),
    column(width = 6, plotOutput("plot2"))
  )
)

server <- function(input, output) {
  dt <- data.frame(x = runif(100), y = runif(100))
  output$plot2 <- renderPlot({
    ggplot(dt, aes(x, y)) + geom_point()
  })

  # -------------------------------------------------------------------
  # Single zoomable plot (on left)
  ranges <- reactiveValues(x = NULL, y = NULL)
  cow_file <- system.file("extdata", "cow.jpg", package = "cowplot")
  output$plot1 <- renderPlot({
    ggdraw(plot = NULL, xlim = ranges$x, ylim = ranges$y) +
      draw_image(cow_file)
  })

  # When a double-click happens, check if there's a brush on the plot.
  # If so, zoom to the brush bounds; if not, reset the zoom.
  observeEvent(input$plot1_dblclick, {
    brush <- input$plot1_brush
    if (!is.null(brush)) {
      ranges$x <- c(brush$xmin, brush$xmax)
      ranges$y <- c(brush$ymin, brush$ymax)

    } else {
      ranges$x <- NULL
      ranges$y <- NULL
    }
  })

}

shinyApp(ui, server)