Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- require('shiny')
- require('ggplot2')
- require('DT')
- require('shinyjs')
- ui <- pageWithSidebar(
- headerPanel("Hover off the page"),
- sidebarPanel(width = 2
- ),
- mainPanel(
- shinyjs::useShinyjs(),
- tags$head(
- tags$style('
- #my_tooltip {
- position: absolute;
- pointer-events:none;
- width: 10;
- z-index: 100;
- padding: 0;
- font-size:10px;
- line-height:0.6em
- }
- ')
- ),
- plotOutput('FP1Plot1' ,
- width = 1000,
- height = 800,
- hover = hoverOpts(id = 'FP1Plot_1_hover', delay = 0)
- ),
- uiOutput("my_tooltip"),
- uiOutput("my_tooltip_style"),
- style = 'width:1250px'
- )
- )
- server <- function(input, output, session) {
- # ranges <- reactiveValues()
- output$FP1Plot1 <- renderPlot({
- ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() #+
- # coord_cartesian(xlim = ranges[[paste('FP1Plot1', 'x', sep = '')]],
- # ylim = ranges[[paste('FP1Plot1', 'y', sep = '')]]
- # )
- })
- # turn the hovers into 1 single reactive containing the needed information
- hoverReact <- reactive({
- ## in my real app I observer hover of all sub plots of all stages (7 pages with a multilot object)
- ## followed by code to store the page ID and plot NR as elements in hoverReact()
- hover <- input[['FP1Plot_1_hover']]
- if(is.null(hover)) return(NULL)
- hover
- })
- ## debounce the reaction to calm down shiny
- hoverReact_D <- hoverReact %>% debounce(100) ## attempt to stop hoverData <- reactive({}) from firing too often, which is needed when you have 10k point scatter plots.....
- hoverData <- reactive({
- hover <- hoverReact_D()
- if(is.null(hover)) return(NULL)
- ## in my multi plot multi data frame I look up which dataframe to grab based on hover$plot_id as well as which x and y parameter are plotted
- hoverDF <- nearPoints(mtcars, coordinfo = hover, threshold = 15, maxpoints = 1, xvar = 'wt', yvar = 'mpg')
- hoverDF
- })
- hoverPos <- reactive({
- ## here I look up the position information of the hover whenevver hoverReact_D and hoverData change
- hover <- hoverReact_D()
- hoverDF <- hoverData()
- if(is.null(hover)) return(NULL)
- if(nrow(hoverDF) == 0) return(NULL)
- ## in my real app the data is already
- X <- hoverDF$wt[1]
- Y <- hoverDF$mpg[1]
- left_pct <-
- (X - hover$domain$left) / (hover$domain$right - hover$domain$left)
- top_pct <-
- (hover$domain$top - Y) / (hover$domain$top - hover$domain$bottom)
- left_px <-
- (hover$range$left + left_pct * (hover$range$right - hover$range$left)) /
- hover$img_css_ratio$x
- top_px <-
- (hover$range$top + top_pct * (hover$range$bottom - hover$range$top)) /
- hover$img_css_ratio$y
- list(top = top_px, left = left_px)
- })
- observeEvent(hoverPos(), {
- req(hoverPos())
- hover <- hoverPos()
- if(is.null(hover)) return(NULL)
- offX <- if(hover$left > 350) {-400} else {30}
- offY <- if(hover$top > 350) {-290} else {10 }
- print('sending css')
- print(offY)
- runjs(paste0( "$(document).ready(function() {",
- "setTimeout(function(){",
- "$('[id^=FP1Plot]').mousemove(function(e) {",
- "$('#my_tooltip').show();",
- "$('#my_tooltip').css({",
- "top: (e.offsetY +", offY, " ) + 'px',",
- "left: (e.offsetX +", offX, ") + 'px'",
- "});",
- "});",
- "})});") )
- }, priority = -1)
- output$GGHoverTable <- DT::renderDataTable({
- df <- hoverData()
- if(!is.null(df)) {
- if(nrow(df)){
- df <- df[1,]
- DT::datatable(t(df), colnames = rep("", nrow(df)),
- options = list(dom='t',ordering=F, autowidth = T))
- }
- }
- })
- output$my_tooltip <- renderUI({
- req(hoverData())
- req(nrow(hoverData())>0 )
- print('sending table')
- wellPanel(
- dataTableOutput('GGHoverTable'),
- style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
- })
- }
- shinyApp(ui, server)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement