在 Shiny R 中显示 ggiraph plot 的叠加页面 onclick

Question

I an R shiny app, I want to show an overlay page with additional information to a data point when clicking on a {ggiraph} scatterplot.

I want to dynamically construct this overlay page as renderUI in R, which is why I do not want to use {ggiraph}'s integrated onlick function. But if there is an easy implementation of a pure javascript solution involving {ggiraph}'s onlick function, then I would be interested. However, keep in mind that I want to display several columns of a data.frame in R in said overlay page, so in case of a pure javascript solution the page would need to be constructed as HTML in javascript, I guess.

My current approach uses {ggiraph}'s input$plot_selected to subset the underlying data, which I use to build a dynamic overlay page. Since this is a reactive endpoint, I use a javascript mutationObserver that tracks changes of the DOM tree, and once its triggered it will toggle the overlay page. Ideally I only want to listen to changes of the dynamic overlay page. However, I am not able to target the corresponding node. Any attempt yields the error:

TypeError: Argument 1 ('target') to MutationObserver.observe must be an instance of Node

I looked at this SO question and also at the documentation of the mutationObserver as well as all the examples mentioned here , but I do not see a reason, why my javascript wouldn't work with

target = document.getElementById('targetthis')

Where targetthis is a hard coded div around the dynamic overlay page.

However, if I target document.body instead it works fine, but now any changes to the DOM tree will toggle the overlay page. In my example there is a selectInput which does but should not toggle the overlay page. I'm also confused that the configuration of the mutationObserver only works with childList where I thought it would work with characterData (because the text of the overlay page changes dynamically).

Another possibility I see, is to start the mutationObserver onclick of the graph and disconnect it once the overlay page is displayed. In this case I could use document.body as target. But it seems overly complex for the task at hand.

I would appreciate any help.

Here is a reproducible example:

library(shiny)
library(ggplot2)
library(ggiraph)

jsCode <- "
// select the target node
var target = document.getElementById('targetthis')  

// create an observer instance
var observer = new MutationObserver(function(mutations) {
  mutations.forEach(function(mutation) {
    if( document.getElementById('overlay')) {
    document.getElementById('overlay').style.display = 'block';
    }
  });    
});

// configuration of the observer:
// it works with childList although I would expect it to work with characterData
var config = {
  childList: true,
  subtree: true,
  // attruibutes: true,
  // characterData: true
};

// pass in the target node, as well as the observer options
// doesn't work if target is used instead of document.body
observer.observe(document.body, config); 
    
function off() {
  document.getElementById('overlay').style.display = 'none';
}
"

shinyApp(ui = fluidPage(
  
  tags$script(jsCode),

  # overlay css
  tags$head(
    tags$style(HTML("
#overlay {
  position: fixed;
  display: none;
  width: 100%;
  height: 100%;
  top: 0;
  left: 0;
  right: 0;
  bottom: 0;
  background-color: rgba(0,0,0,0.5);
  z-index: 2;
  cursor: pointer;
}

#profile {
  color: black;
  background-color: white;
  position: absolute;
  top: 50%;
  left: 50%;
  font-size: 50px;
  transform: translate(-50%,-50%);
  -ms-transform: translate(-50%,-50%);
}

    "))
  ),

  sidebarLayout(

  sidebarPanel(
    # test input overlay page should not be shown when input changes
    selectInput("test",
                "This is a test input",
                choices = c("Model A", "Model B", "Model C"))
  ),
  mainPanel(
    # plot
    girafeOutput("plot"),
    # overlay html
    # this hard coded div contains the overlay page 
    div(id = "targetthis",
                 uiOutput("overlay_page")),
    )
)),

  server = function(input, output) {

    # dynamic overlay page
    # preferably I want to build this page inside R (and not javascriptto,)
    output$overlay_page <- renderUI({
      
      info <- subset(mtcars, rownames(mtcars) == input$plot_selected)
      
    tagList(div(id = "overlay",
                onclick = "off()",
                tags$table(id = "profile",
                           style="width:80%",
                  tags$tr(
                    tags$th(colspan = 3,
                            rownames(info))
                  ),
                  tags$tr(
                    tags$td(colnames(info)[1]),
                    tags$td(info[, 1])
                  ),
                  tags$tr(
                    tags$td(colnames(info)[2]),
                    tags$td(info[, 2])
                  ),
                  tags$tr(
                    tags$td(colnames(info)[3]),
                    tags$td(info[, 3])
                  ),
                  tags$tr(
                    tags$td(colnames(info)[4]),
                    tags$td(info[, 4])
                  )
                  )
      )
      )
    
    })

    # plot
    output$plot <- renderGirafe({

      
      data <- mtcars

      p <- ggplot(aes(x = wt,
                      y = mpg,
                      data_id = row.names(mtcars)
                      ),
                  data = data) +
        geom_point_interactive(size = 3) +
        theme_minimal()

      girafe(
        ggobj = p,
        options = list(
          opts_hover(css = "fill:red;cursor:pointer;"),
          opts_selection(type = "single")
        )
      )
    })

  }

)

Answer 1

@VictorPerrier commented on Twitter to just use a modal window with modalDialog , which I totally did not have in mind. I played around with it and it pretty much does what I want it to do without one line of javascript (see code below).

I will leave this question open, just in case someone has a "real" overlay page solution (which I do not need for my use case, but someone else might be looking for it). And of course, after spending some time with the mutationObserver API I would really like to know, why my approach is not working.

library(shiny)
library(ggplot2)
library(ggiraph)


shinyApp(ui = fluidPage(

  sidebarLayout(

  sidebarPanel(
    # test input overlay page should not be shown when input changes
    selectInput("test",
                "This is a test input",
                choices = c("Model A", "Model B", "Model C"))
  ),
  mainPanel(
    # plot
    girafeOutput("plot")
))),

  server = function(input, output) {

    # dynamic overlay page
    # preferably I want to build this page inside R (and not javascriptto,)
    observeEvent(input$plot_selected, {
      
      info <- subset(mtcars, rownames(mtcars) == input$plot_selected)
      
      showModal(shiny::modalDialog(
      
      tags$table(id = "profile",
                 style="width:80%",
                 tags$tr(
                   tags$th(colspan = 3,
                           rownames(info)
                   )
                 ),
                 tags$tr(
                   tags$td(colnames(info)[1]),
                   tags$td(info[, 1])
                 ),
                 tags$tr(
                   tags$td(colnames(info)[2]),
                   tags$td(info[, 2])
                 ),
                 tags$tr(
                   tags$td(colnames(info)[3]),
                   tags$td(info[, 3])
                 ),
                 tags$tr(
                   tags$td(colnames(info)[4]),
                   tags$td(info[, 4])
                 )
      ),
      easyClose = TRUE,
      footer = NULL
      ))
    })

    # plot
    output$plot <- renderGirafe({

      data <- mtcars

      p <- ggplot(aes(x = wt,
                      y = mpg,
                      data_id = row.names(mtcars)
                      ),
                  data = data) +
        geom_point_interactive(size = 3) +
        theme_minimal()

      girafe(
        ggobj = p,
        options = list(
          opts_hover(css = "fill:red;cursor:pointer;"),
          opts_selection(type = "single")
        )
      )
    })

  }

)