Call to grid::convertUnit in Shiny App makes plotOutput blank (requires OS restart to fix)

[ghost]

System details

Browser Version: NA

Output of sessionInfo():

R version 3.5.1 (2018-07-02)
Platform: x86_64-pc-linux-gnu (64-bit)
Running under: Ubuntu 16.04.5 LTS

Matrix products: default
BLAS: /usr/lib/openblas-base/libblas.so.3
LAPACK: /usr/lib/libopenblasp-r0.2.18.so

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C               LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8     LC_MONETARY=en_US.UTF-8   
 [6] LC_MESSAGES=en_US.UTF-8    LC_PAPER=en_US.UTF-8       LC_NAME=C                  LC_ADDRESS=C               LC_TELEPHONE=C            
[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       

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

other attached packages:
[1] ggplot2_3.3.1    shiny_1.4.0.9002 roxygen2_6.1.1   usethis_1.4.0    devtools_2.0.1  

loaded via a namespace (and not attached):
  [1] colorspace_1.3-2            ellipsis_0.3.0              rsconnect_0.8.12            rprojroot_1.3-2             biovizBase_1.30.1          
  [6] htmlTable_1.12              XVector_0.22.0              GenomicRanges_1.34.0        base64enc_0.1-3             fs_1.2.6                   
 [11] dichromat_2.0-0             rstudioapi_0.11             remotes_2.1.1               bit64_0.9-7                 AnnotationDbi_1.44.0       
 [16] xml2_1.2.0                  splines_3.5.1               knitr_1.21                  shinythemes_1.1.2           pkgload_1.0.2              
 [21] Formula_1.2-3               jsonlite_1.6.1              Rsamtools_1.34.0            Cairo_1.5-9                 cluster_2.0.7-1            
 [26] BiocManager_1.30.4          compiler_3.5.1              httr_1.4.0                  rvcheck_0.1.8               backports_1.1.2            
 [31] lazyeval_0.2.1              assertthat_0.2.0            Matrix_1.2-15               fastmap_1.0.1               cli_1.0.1                  
 [36] later_1.0.0                 acepack_1.4.1               htmltools_0.4.0.9003        prettyunits_1.0.2           tools_3.5.1                
 [41] gtable_0.2.0                glue_1.4.0                  GenomeInfoDbData_1.2.0      dplyr_0.8.5                 Rcpp_1.0.4.6               
 [46] Biobase_2.42.0              vctrs_0.2.4                 Biostrings_2.50.1           rtracklayer_1.42.1          xfun_0.4                   
 [51] stringr_1.3.1               ps_1.2.1                    testthat_2.0.1              mime_0.9                    lifecycle_0.2.0            
 [56] ensembldb_2.6.8             XML_3.98-1.16               zlibbioc_1.28.0             scales_1.0.0                BSgenome_1.50.0            
 [61] VariantAnnotation_1.28.3    ProtGenerics_1.14.0         hms_0.4.2                   promises_1.1.0              parallel_3.5.1             
 [66] SummarizedExperiment_1.12.0 AnnotationFilter_1.6.0      RColorBrewer_1.1-2          curl_3.2                    memoise_1.1.0              
 [71] gridExtra_2.3               biomaRt_2.38.0              rpart_4.1-13                latticeExtra_0.6-28         stringi_1.2.4              
 [76] RSQLite_2.1.1               S4Vectors_0.20.1            desc_1.2.0                  checkmate_1.8.5             GenomicFeatures_1.34.1     
 [81] BiocGenerics_0.28.0         pkgbuild_1.0.2              BiocParallel_1.16.2         GenomeInfoDb_1.18.1         rlang_0.4.6                
 [86] pkgconfig_2.0.2             commonmark_1.7              matrixStats_0.54.0          bitops_1.0-6                lattice_0.20-38            
 [91] purrr_0.2.5                 labeling_0.3                GenomicAlignments_1.18.0    htmlwidgets_1.5.1           cowplot_1.0.0              
 [96] bit_1.1-14                  processx_3.2.1              tidyselect_0.2.5            magrittr_1.5                R6_2.4.1                   
[101] IRanges_2.16.0              Hmisc_4.1-1                 DelayedArray_0.8.0          DBI_1.0.0                   pillar_1.4.3               
[106] foreign_0.8-71              withr_2.2.0                 survival_2.43-3             RCurl_1.95-4.11             nnet_7.3-12                
[111] tibble_3.0.1                crayon_1.3.4                progress_1.2.0              grid_3.5.1                  data.table_1.11.8          
[116] blob_1.1.1                  callr_3.1.0                 digest_0.6.25               xtable_1.8-4                httpuv_1.5.2               
[121] gridGraphics_0.5-0          stats4_3.5.1                munsell_0.5.0               ggplotify_0.0.5             Gviz_1.26.5                
[126] sessioninfo_1.1.1 

Example Application

library(shiny)
library(ggplot2)

ui <- fluidPage(
    column(12,
      absolutePanel(
        wellPanel(id="WP",
          fluidRow(column(12, selectInput("ldblock_selector",
                                          label="LD Blocks to Plot",
                                          choices=c("Select block(s):" = "", c("b1", "b2")),
                                          width="180px",
                                          multiple=TRUE), 
                          align="left")),
          fluidRow(column(12, actionButton("locusZoom_go",
                                           label="Plot",
                                           icon=icon("chart-line"),
                                           width="100px"),
                          align="center"))),
        top=0, bottom=0, left=0, width="200px"),
      absolutePanel(
        column(12,
          tags$div(class="ldplot",
            # The tooltip and the plot should be in the same div, with relative
            # positions. See https://github.com/rstudio/shiny/issues/2239
            style="position:relative; margin-top:0px; margin-bottom:0px; margin-left:0px; margin-right:0px; padding-left:0px; padding-right:0px; padding-top:0px; padding-bottom:0px;",
            plotOutput(outputId="lp",
                        height="900px",
                        hover=hoverOpts(id="lp_hover")),
            uiOutput(outputId="lp_hover_info")),
            style="margin-left:0px; margin-right:0px; padding-left:0px; padding-right:0px;"),
      top=0, bottom=0, left="210px", right="0px", style="margin-left:0px; margin-right:0px;"),
    style="margin-top:20px; margin-bottom:20px;"), theme=shinythemes::shinytheme("slate")
)

server <- function(input, output, session) {
    # Extract the (x,y) coordinates of the points in the Manhattan plot
    # portion of a LocusZoom plot returned by plot_grid
    #
    # This code was adapted from
    # https://stackoverflow.com/questions/60803424/npc-coordinates-of-geom-point-in-ggplot2
    #
    # @param pg The object returned by cowplot::plot_grid
    # @param session The session data
    # @return A dataframe with the columns c("x", "y"), containing the npc
    # coordinates of each variant. The dataframe is sorted by x.
    # -------------------------------------------------------------------------
    get_x_y_values <- function(pg, session) {
      # Using the grid package, define a function to convert coordinates into
      # units of mm.
      to_mm <- function(x) {grid::convertUnit(x, "mm", valueOnly = TRUE)}

      # Get the grob encoding the Manhattan Plot panel
      gt <- pg$layers[[1]]$geom_params$grob

      # Get the coordinates/dimensions of the Manhattan Plot panel containing all
      # the variants
      idx_panel    <- which(gt$layout$name == "panel")
      panel_pos    <- pg$layers[[1]]$geom_params$grob$layout[idx_panel, ]

      # WHEN I UNCOMMENT THIS LINE OF CODE, IT CAUSES PROBLEMS THAT REQUIRE RESTARTING THE OS (UBUNTU)!
      #
      #from_top     <- sum(to_mm(gt$heights[seq(panel_pos$t - 1)]))
      #

      # The return result doesn't matter. Only the line of code immediately above.
      return(NULL)
    }

    # Get the selected LD block
    getSelectedBlocks <- reactive({
      # Get the user selections
      ldblk.sels <- input$ldblock_selector
      if (length(ldblk.sels) < 1) {return(character())}

      # {The user has selected at least one LD block}

      return(ldblk.sels)
    })

    # Get the data required by the LocusZoom plot
    lz.data <- eventReactive(input$locusZoom_go, {
      # Define an empty data frame to return in the case of an error
      null.df <- data.frame(live.rsid=character(),
                            chr=character(),
                            pos=numeric(),
                            MAF=numeric(),
                            ppa=numeric(),
                            assocSig=numeric(),
                            r=numeric(),
                            rsq=numeric(),
                            stringsAsFactors=FALSE)

      # Validate the LD block(s)
      ldbs <- getSelectedBlocks() 
      if (length(ldbs) < 1) {return(null.df)}

      # {The LD blocks are valid}

      # Get the reference SNP
      refsnp <- "rs4511375"

      # {All the inputs have been validated}

      # Load the data from file
      #zdata <- read.table("~/Documents/zdata2.tsv", header=TRUE, sep="\t", quote="", stringsAsFactors = FALSE)
      zdata <- data.frame(live.rsid=c("rs4511375", "rs11612782", "rs7295594"), 
                             chr=as.integer(c(12, 12, 12)), 
                             pos=as.numeric(c(106035444, 106038330, 106043106)), 
                             MAF=c(0.249950, 0.250223, 0.250058), 
                             ppa=c(0.0002577914, 0.0002163303, 0.0002209099), 
                             assocSig=c(2.593869, 2.507715, 2.518070), 
                             r=c(1.0, 0.9987770, 0.9987347), 
                             rsq=c(1.0, 0.9975554, 0.9974709), 
                             stringsAsFactors=F)

      # Return the data for the LocusZoom plot
      return(zdata)
    })

    # Generate the LocusZoom Plot
    lp.plot <- reactive({
      # Get the data
      zdata <- lz.data()

      # If the data are NULL, return an empty plot
      if (nrow(zdata) < 1) {
        pg <- ggplot() +
              ggtitle("LocusZoom Plot") +
              theme_bw() +
              theme(plot.title = element_text(size=24,
                                              hjust=0.5,
                                              face="bold",
                                              color="grey",
                                              margin=margin(10, 0, 10, 0)))
        return(list(pg=pg, mph=1, df=zdata))
      }

      # {We have valid data to plot}

      # Get the chromosome (a UCSC chromosome name)
      ucsc.chr <- "chr12"

      # Get the reference SNP
      refsnp <- "rs4511375"

      # Map the squared Pearson correlations into the color scale
      zdata$rsq[zdata$rsq <= 0] <- .Machine$double.eps
      zdata$colors <- cut(zdata$rsq, c(0, 0.2, 0.4, 0.6, 0.8, 1.0))

      # Get the range of the genomic locus
      xlims <- c(105818878, 106155478)

      # Generate the Manhattan plot component of the LocusZoom plot
      mhp <- ggplot(zdata, aes(x=pos, y=assocSig)) +

      # Show all points
      geom_point(aes(color=colors), alpha=1.0, size=1.8) +
      scale_color_manual(name=expression(R^{"2"}),
                         values=c("#357EBDFF", "#46B8DAFF", "#5CB85CFF", "#EEA236FF", "#D43F3AFF")) +
      guides(color = guide_colorsteps(show.limits = TRUE, even.steps = TRUE)) +

      # Highlight the reference SNP in purple
      geom_point(data=zdata[zdata$live.rsid == refsnp,], color="#9632B8FF", size=1.8) +

      # Label the axes
      xlab("Position (bp)") +
      ylab(bquote(-log[10](italic(p)))) +

      # Title the figure
      ggtitle("LocusZoom Plot") +

      # Customize the axes:
      # 1.) Ensure there is no extra space at the edges of the axes
      # 2.) Set the range of the axes
      scale_x_continuous(expand=c(0,0), limits=xlims) +
      scale_y_continuous(expand=c(0, 0), limits=c(0, max(zdata$assocSig)+1)) +

      # Customize the theme
      theme_bw() +
      theme(axis.line=element_blank(),
            axis.text.x=element_blank(),
            axis.title.x=element_blank(),
            plot.margin=margin(0, 0, 0, 0),
            panel.border = element_blank(),
            panel.grid.major.x = element_blank(),
            panel.grid.minor.x = element_blank(),
            axis.text.y = element_text(size=14),
            axis.title.y = element_text(size=18),
            plot.title = element_text(size=24, hjust=0.5, face="bold", margin=margin(10, 0, 10, 0)))

      # Grab the Gviz plot with the gene models track
      gzp <- grid::grid.grabExpr(plt <- Gviz::plotTracks(Gviz::GenomeAxisTrack(labelPos="above"),
                                             collapseTranscripts="meta",
                                             shape="arrow",
                                             transcriptAnnotation="symbol",
                                             title.width=0,
                                             add=T,
                                             from=xlims[1],
                                             to=xlims[2],
                                             margin=0,
                                             innerMargin=0))

      # Align the Manhattan plot with the Gviz tracks
      gzp <- ggplotify::as.ggplot(gzp)
      pg <- cowplot::plot_grid(mhp, gzp, align="v", axis="lr", nrow=2, ncol=1, rel_heights=c(8,2))

      # Return both the plot object and the underlying data
      return(list(pg=pg, df=zdata))
    })

    # Generate the LocusZoom plot whenever a user clicks the plot button
    output$lp <- renderPlot({lp.plot()$pg})

    # Render the tooltip for the Manhattan plot
    output$lp_hover_info <- renderUI({
      # Get the plot data
      plot.data <- lp.plot()

      # Return NULL if nothing is plotted
      zdata <- plot.data$df
      if (nrow(zdata) < 1) {return(NULL)}

      # Get the mouseover event
      hover <- input$lp_hover

      # Get the (x,y) coordinates of each variant in the current viewport
      xy.df   <- get_x_y_values(plot.data$pg, session)
      #zdata$x <- xy.df$x
      #zdata$y <- xy.df$y
      zdata$x <- 0
      zdata$y <- 0

      # Get the variant which is nearest to the cursor
      point <- nearPoints(zdata, hover, xvar="x", yvar="y", threshold=1000000, maxpoints=nrow(zdata), addDist=FALSE)
      if (nrow(point) == 0) {return(NULL)}
      point$dist <- sqrt((point$x-hover$x)^2 + (point$y-hover$y)^2)
      #point <- point[point$dist <= 0.025, ]
      if (nrow(point) == 0) {return(NULL)}
      point <- as.data.frame(data.table::setorder(data.table::as.data.table(point), dist))
      point <- point[1,]

      # Calculate distance from left and bottom side of the plot, in pixels
      left_px <- hover$range$left + hover$x * (hover$range$right - hover$range$left)
      top_px  <- hover$range$top  + (1.0 - hover$y) * (hover$range$bottom - hover$range$top)

      # On offset is required to ensure that the tooltip does not overlap the
      # mouse. See https://github.com/rstudio/shiny/issues/2239
      offset <- 5

      # Style the tooltip:
      # background color is set so tooltip is a bit transparent
      # z-index is set to ensure tooltip will be on top
      style  <- paste0("position:absolute; z-index:100; color: rgb(50, 50, 50); background-color: rgba(245, 245, 245, 0.85); ",
                       "left:", left_px + offset, "px; top:", top_px + offset, "px;")

      # Render the tooltip as a wellPanel
      wellPanel(
        style = style,
        p(HTML(paste0("<b> SNP:    </b>", point$live.rsid,             "<br/>",
                      "<b> Pos:    </b>", point$pos,                   "<br/>",
                      "<b> MAF:    </b>", round(point$MAF,  digits=3), "<br/>",
                      "<b> R:      </b>", signif(point$r,   digits=3), "<br/>",
                      "<b> PPA:    </b>", signif(point$ppa, digits=3), "<br/>")))
      )
    })

}

shinyApp(ui=ui, server=server)

Steps to Reproduce

To reproduce the problem, please follow these steps: 1.) In the function get_x_y_values, please uncomment the line "#from_top <- sum(to_mm(gt$heights[seq(panel_pos$t - 1)]))" But note that the bug caused by this line may require you to restart your computer to fix it (i.e., comment out the line, restart the OS, then re-run the app)

2.) Run the shiny app. (I do this in RStudio.)

3.) Choose "b1" (or "b2", it doesn't matter) from the dropdown menu.

4.) Click the Plot button. The plot will be empty. This is the first sign of trouble. Maximize the window and the plot will become visible.

5.) Remove the "b1" selection and click the Plot button again. This will clear the plot correctly.

6.) Select "b1" and plot again. The plot will be empty.

If you follow these steps with the troublesome line commented out--assuming the bad code has not run without restarting the OS--this is the expected behavior: 4.) Click the Plot button. The plot will render regardless of the initial window size. Maximize/minimize the window; the plot remains visible and is correctly resized.

6.) Select "b1" and plot again. The plot should appear just as it did the first time.

App and Bug Description

The Plot button, when clicked, generates a ggplot and a Gviz plot, tied together by cowplot::plot_grid. The tricky part is that I've implemented functionality to report information about the points in the ggplot whenever the user hovers the mouse over the plot. Since the plot is actually a composite of the ggplot and another object from the Gviz package, this functionality requires some transformations from the coordinates reported by the hover info to the coordinates of the points in the underlying plot object. To compute that transformation, I make calls to grid::convertUnit in the callback function that gets invoked on mouseover events. Even a single call to grid::convertUnit in this context causes the sporadic rendering described above. Interestingly, the problem persists after I comment out the offending line of code. It persists even when I close the RStudio session and restart!! I have to actually restart my OS (I'm running Ubuntu 16.04) to get back to the original behavior.

[ghost]

If I move the grid::convertUnit calls into the lp.plot() reactive, where the plot_grid function is called, those calls are safe. Perhaps the problem is invoking grid::convertUnit on a grob that may have been created in a different viewport? I think I can achieve my desired functionality by restricting all my calls to grid::convertUnit within the same context in which the plotting functions are called (i.e., lp.plot()), but I'm still surprised that invoking the function in the wrong place induces this sporadic and persistent rendering bug. The fact that it requires an OS restart makes me think some internal state of the graphics engine is being corrupted, which seems like a bug, particularly in a base R package.

[ghost]

I've now tested and validated a solution that circumvents this problem. The solution is actually better designed code, rather than a hack/workaround, so I'm OK if this issue is closed. In general, I admit that one should avoid calling conversion routines on grobs in a context where the viewport may have changed since plot creation. But there could be use cases where this is desired, for instance when the change in viewport is properly taken into account. And the strange persistence of the bug may bewilder unsuspecting application developers. I'm also troubled by the possibility that simply calling the conversion utilities in the wrong place is corrupting some internal data in the graphics engine.

[ghost]

Also, I'm not sure whether the problem is: 1.) calling the conversion utility on a grob after a change in viewport; or 2.) calling the conversion utility in a mouseover event callback

[wch]

It sounds like this is a bug in R itself, or possibly in the grid package. I suggest trying to create a minimal reproducible example (without shiny) and posting it to the R-devel mailing list, or filing in the R bugzilla tracker.

[cpsievert]

Closing since it appears you've found a workaround

I've now tested and validated a solution that circumvents this problem. The solution is actually better designed code, rather than a hack/workaround, so I'm OK if this issue is closed.