R Shiny 笔刷缩放动态大小的图像

Question

我一直在看 Shiny 中的advanced interactive plots，我正在努力研究如何完成画笔和双击缩放图像，而不是绘图。更复杂的是，我在 Rshiny 小部件中并排显示图像和绘图，因此图像大小是动态的以适合。我不知道如何将像素坐标映射到画笔事件的调整大小的 xy 坐标。有什么方法可以在renderImage 中获取调整大小比率。该应用程序位于一个函数内，并采用一个 Seurat 对象进行绘图并将其呈现在参考图像（我需要放大）旁边。

#' 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

事实证明，在尝试创建一个更可重现的示例时，我发现了一个隐藏在 cowplot 的draw_image 文档中的解决方案。结合ggdraw，您可以定义一个与您的图片对齐的 gg 对象。因此，此时您可以遵循标准的zoom.R模板并在ggdraw中指定反应式ranges$x和ranges$y

# 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)