Mark
Reputation: 2899
How to add custom hover function to plotOutput so it can be used for many plots
I'm experimenting with some code for hover messages on top of ggplot2 objects, and so far it is working quite well, except now the following challenge goes beyond my skills I fear:
In an App where I will have about 6 to 72 similar ggplots spread over various pages in my app, I would like to be able to attach the hover javascript to all of them automatically: i.e. change from a single tags$script to a generic solution that works for all plots
I tried to build a new plotOutput2 function but I can't get it to work at all.
plotOutput2 <- function(outputId, width = "100%", height = "400px", click = NULL,
dblclick = NULL, hover = NULL, hoverDelay = NULL, hoverDelayType = NULL,
brush = NULL, clickId = NULL, hoverId = NULL, inline = FALSE,
onhover) {
input <- plotOutput(outputId, width, height, click, dblclick,
hover, hoverDelay, hoverDelayType, brush, clickId, hoverId, inline)
attribs <- c(input$children[[2]]$attribs, onhover = onhover)
input$children[[2]]$attribs <- attribs
input
}
but I get an error that says:
input$children[[2]] : subscript out of bounds
The idea is to then call this:
plotOutput2("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0), onhover = "hoverJS(this.id)"),
and the javascript (unfinished) needs to look something like this but create unique output ids instead of #my_tooltip that contain the plotname + tooltip: i.e.: #distPlot_tooltip
hoverjs <- c(
"function hoverJS(id){",
"document.getElementById(id).mousemove(function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.pageY + 5) + 'px',",
"left: (e.pageX + 5) + 'px'",
"});",
"});",
"}"
)
with the following line in the UI
tags$script(HTML(hoverjs)), ## to add the javascript to the app
The app with only a single precoded javascript hover popup for one plot (top one of the two) looks like this:
library(shiny)
library(ggplot2)
# put function plotOutput2 here
# put hoverJS code here
ui <- fluidPage(
tags$head(tags$style('
#my_tooltip {
position: absolute;
width: 300px;
z-index: 100;
padding: 0;
}
')),
tags$script('
$(document).ready(function() {
// id of the plot
$("#ploty").mousemove(function(e) {
// ID of uiOutput
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});
'),
#tags$script(HTML(hoverjs)),
selectInput("var_y", "Y-Axis", choices = names(iris)),
plotOutput("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0)),
plotOutput("plotx", hover = hoverOpts(id = "plotx_hover", delay = 0)),
uiOutput("my_tooltip")
)
server <- function(input, output) {
output$ploty <- renderPlot({
req(input$var_y)
ggplot(iris, aes_string("Sepal.Width", input$var_y)) +
geom_point()
})
output$plotx <- renderPlot({
req(input$var_y)
ggplot(mtcars, aes_string("mpg", 'hp')) +
geom_point()
})
output$my_tooltip <- renderUI({
hover <- input$ploty_hover
y <- nearPoints(iris, input$ploty_hover)
req(nrow(y) != 0)
wellPanel(DT::dataTableOutput("vals"), style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- DT::renderDataTable({
hover <- input$ploty_hover
y <- nearPoints(iris, input$ploty_hover)
req(nrow(y) != 0)
DT::datatable(t(y), colnames = rep("", ncol(t(y))), options = list(dom = 't', searching = F, bSort = FALSE))
})
}
shinyApp(ui = ui, server = server)
EDIT based on initial answer:
I will have (currently) 7 groups of plots in my app, each plot name will start with a name identifying the group (each group uses a different data frame): in the example 2 groups: 'FP1Plot' and 'CleanFP1' The subplots within one group will get a serialnr i.e.: 'FP1Plot_1', 'FP1Plot_2', 'CleanFP1_1', 'CleanFP1_2'
I have tried to rewrite the hovers <- .... to make it a easily generated list for the possible huge (>100) number of plots, and will look up the needed dataframe in an if statement construction,
but at this point the hover doesn't react
require('shiny')
require('ggplot2')
require('shinyjqui')
mtcars <- as.data.table(mtcars)
max_plots <- 12;
ui <- pageWithSidebar(
headerPanel("Dynamic number of plots"),
sidebarPanel(width = 2, sliderInput("n", "Number of plots", value=5, min=1, max=max_plots),
h4('click points to see info'),
h4('select area to zoom'),
h4('Double click to unzoom')
),
mainPanel(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
width: 300px;
z-index: 100;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
$("[id^=plot]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});')
),
tabsetPanel(
tabPanel('fp1',
uiOutput("FP1Plotmultiplots")
),
tabPanel('clean',
uiOutput("CleanFP1multiplots")
)
),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
plotlist <- c('FP1Plot', 'CleanFP1')
ranges <- reactiveValues()
# make the individual plots
observe({
lapply(1:input$n, function(i){
plotname <- paste0('FP1Plot', i)
output[[plotname]] <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
coord_cartesian(xlim =ranges[[paste('FP1Plot', i, 'x', sep = '')]],
ylim = ranges[[paste('FP1Plot', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
observe({
lapply(1:input$n, function(i){
plotname <- paste0('CleanFP1', i)
output[[plotname]] <- renderPlot({
ggplot(iris, aes(iris[ ,ncol(iris)-1], iris[ ,i], color = as.factor(Species))) + geom_point() +
coord_cartesian(xlim =ranges[[paste('CleanFP1', i, 'x', sep = '')]],
ylim = ranges[[paste('CleanFP1', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
# make the divs with plots and buttons etc
lapply(plotlist, function(THEPLOT) {
output[[paste(THEPLOT, 'multiplots', sep = '')]] <- renderUI({
plot_output_list <- list()
n <- input$n
n_cols <- if(n == 1) {
1
} else if (n %in% c(2,4)) {
2
} else if (n %in% c(3,5,6,9)) {
3
} else {
4
}
Pwidth <- 900/n_cols
Pheigth <- 500/ceiling(n/n_cols) # calculate number of rows
Pwidth2 <- Pwidth+40
Pheigth2 <-Pheigth+40
plot_output_list <- list();
for(i in 1:input$n) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', THEPLOT, i),
wellPanel(
plotOutput(paste0(THEPLOT, i),
width = Pwidth,
height = Pheigth,
hover = hoverOpts(id = paste(THEPLOT, i, "hover", sep = '_'), delay = 0)
# click = paste0(THEPLOT, i, '_click'),
# dblclick = paste0(THEPLOT, i, '_dblclick'),
# brush = brushOpts(
# id = paste0(THEPLOT, i, '_brush'),
# resetOnNew = TRUE
# )
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = ''))
))
}
do.call(tagList, plot_output_list)
})
})
eg <- expand.grid(plotlist, 1:max_plots)
tooltipTable <- reactive({
## attempt to make this work for the large amount of plots in my app
hovers <- as.list(sapply(c(sprintf('%s_%s', eg[,1], eg[,2])), function(key) key = eval(parse(text = paste('input$', key, '_hover', sep = ''))) ))
notNull <- sapply(hovers, Negate(is.null))
if(any(notNull)){
plotid <- names(which(notNull))
plothoverid <- paste0(plotid, "_hover")
dataset <- if(grepl('FP1Plot', plotid)) { mtcars } else { iris }
## I will add some code here based on the plot nr to grab the needed columns for the x and y data of the specific plot, since the list of x and y columns will be stored in two vectors:
## 1 vector with x parameter 1:12, and 1 for y.
## every group of plots will use the same list of selected x and y parameters
# (or if I switch to plot group specific lists, the lists will contain the group names just like the plots, so I can link them by name here)
y <- nearPoints(dataset, input[[plothoverid]],
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui, server)
Upvotes: 1
Views: 1010
Answers (1)
Stéphane Laurent
Reputation: 84529
I don't understand the general context, but maybe this can help:
library(shiny)
library(ggplot2)
library(DT)
ui <- fluidPage(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
width: 300px;
z-index: 100;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
$("[id^=plot]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});')
),
selectInput("var_y", "Y-Axis", choices = names(iris)),
plotOutput("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0)),
plotOutput("plotx", hover = hoverOpts(id = "plotx_hover", delay = 0)),
uiOutput("my_tooltip")
)
datasets <- list(plotx = mtcars, ploty = iris)
server <- function(input, output) {
output$ploty <- renderPlot({
req(input$var_y)
ggplot(iris, aes_string("Sepal.Width", input$var_y)) + geom_point()
})
output$plotx <- renderPlot({
ggplot(mtcars, aes_string("mpg", 'hp')) + geom_point()
})
tooltipTable <- reactive({
hovers <- list(plotx = input$plotx_hover, ploty = input$ploty_hover)
notNull <- sapply(hovers, Negate(is.null))
if(any(notNull)){
plotid <- names(which(notNull))
plothoverid <- paste0(plotid, "_hover")
y <- nearPoints(datasets[[plotid]], input[[plothoverid]],
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui = ui, server = server)
Update
require('shiny')
require('ggplot2')
library(DT)
#mtcars <- as.data.table(mtcars)
max_plots <- 12;
ui <- pageWithSidebar(
headerPanel("Dynamic number of plots"),
sidebarPanel(width = 2, sliderInput("n", "Number of plots", value=5, min=1, max=max_plots),
h4('click points to see info'),
h4('select area to zoom'),
h4('Double click to unzoom')
),
mainPanel(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
width: 300px;
z-index: 100;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
setTimeout(function(){
$("[id^=FP1Plot],[id^=CleanFP1]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.offsetY) + "px",
left: (e.pageX + 5) + "px"
});
});
},5000)});')
),
tabsetPanel(
tabPanel('fp1',
div(style = "position:relative",
uiOutput("FP1Plotmultiplots"))
),
tabPanel('clean',
uiOutput("CleanFP1multiplots")
)
),
uiOutput("my_tooltip"),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
plotlist <- c('FP1Plot', 'CleanFP1')
ranges <- reactiveValues()
# make the individual plots
observe({
lapply(1:input$n, function(i){
plotname <- paste0('FP1Plot', i)
output[[plotname]] <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
coord_cartesian(xlim =ranges[[paste('FP1Plot', i, 'x', sep = '')]],
ylim = ranges[[paste('FP1Plot', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
observe({
lapply(1:input$n, function(i){
plotname <- paste0('CleanFP1', i)
output[[plotname]] <- renderPlot({
x <- names(iris)[ncol(iris)-1]
y <- names(iris)[i]
ggplot(iris, aes_string(x, y, color = "Species")) + geom_point() +
coord_cartesian(xlim =ranges[[paste('CleanFP1', i, 'x', sep = '')]],
ylim = ranges[[paste('CleanFP1', i, 'y', sep = '')]]
) +
theme_classic() +
theme(legend.text=element_text(size=12),
legend.title=element_blank(),
legend.position = 'bottom')
})
})
})
# make the divs with plots and buttons etc
lapply(plotlist, function(THEPLOT) {
output[[paste(THEPLOT, 'multiplots', sep = '')]] <- renderUI({
plot_output_list <- list()
n <- input$n
n_cols <- if(n == 1) {
1
} else if (n %in% c(2,4)) {
2
} else if (n %in% c(3,5,6,9)) {
3
} else {
4
}
Pwidth <- 900/n_cols
Pheigth <- 500/ceiling(n/n_cols) # calculate number of rows
Pwidth2 <- Pwidth+40
Pheigth2 <- Pheigth+40
plot_output_list <- list();
for(i in 1:input$n) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', THEPLOT, i),
wellPanel(
plotOutput(paste0(THEPLOT, i),
width = Pwidth,
height = Pheigth,
hover = hoverOpts(id = paste(THEPLOT, i, "hover", sep = '_'), delay = 0)
# click = paste0(THEPLOT, i, '_click'),
# dblclick = paste0(THEPLOT, i, '_dblclick'),
# brush = brushOpts(
# id = paste0(THEPLOT, i, '_brush'),
# resetOnNew = TRUE
# )
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = ''))
))
}
do.call(tagList, plot_output_list)
})
})
eg <- expand.grid(plotlist, 1:max_plots)
plotids <- sprintf('%s_%s', eg[,1], eg[,2])
names(plotids) <- plotids
tooltipTable <- reactive({
hovers <-
lapply(plotids, function(key) input[[paste0(key, '_hover')]])
notNull <- sapply(hovers, Negate(is.null))
if(any(notNull)){
plotid <- names(which(notNull))
plothoverid <- paste0(plotid, "_hover")
dataset <- if(grepl('FP1Plot', plotid)) { mtcars } else { iris }
## I will add some code here based on the plot nr to grab the needed columns for the x and y data of the specific plot, since the list of x and y columns will be stored in two vectors:
## 1 vector with x parameter 1:12, and 1 for y.
## every group of plots will use the same list of selected x and y parameters
# (or if I switch to plot group specific lists, the lists will contain the group names just like the plots, so I can link them by name here)
y <- nearPoints(dataset, input[[plothoverid]],
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui, server)
Upvotes: 1
Related Questions
- ToolTip when you mouseover a ggplot on shiny
- How to customize hover information in ggplotly object?
- How hover plot inputs over the plot itself in R Shiny?
- How do I show the y value on tooltip while hover in ggplot2
- How to add hover option with multiple row in ggplot2 bar chart?
- how change hover text in plotly
- ggplot hoverOpts not working as expected compared to old style hover
- R and Shiny: Show ggplot2 data values when hovering over the plot in Shiny
- How to change a plot when hovering over elements in Shiny?
- Adding markers and display the tooltip in R