Reputation: 18561
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")
)
)
})
}
)
Upvotes: 1
Views: 507
Reputation: 18561
@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")
)
)
})
}
)
Upvotes: 3