How to place shiny panel near the pointer/mouse?

Question

I am building a shiny webapp in which I need to show plot points when hover over them. I managed to solve this by placing x, y , and other info of my array in a fixed draggable absolutepane. Is there a way to place this panel everytime the mouse hover over a point near the pointer ? Also, how can I hide the panel if the mouse isn't hovering any point ? Currently, the panel is draggable and fixed at the top of the page using this code

ui <- shinyUI(fluidPage(       
  absolutePanel(fixed=TRUE, draggable = TRUE,
                verbatimTextOutput("hover_info")
  ),
  plotOutput("myplot",
             hover = hoverOpts(id ="myplot_hover")
  )
))

server <- shinyServer(function(input, output) {

  output$myplot <- renderPlot({
    ggplot(mtcars) + geom_point(aes(mpg,cyl))
                            })

  output$hover_info <- renderPrint({
    nearPoints(mtcars, input$myplot_hover,maxpoints=1)
                                  })
})

shinyApp(ui, server)

Thanks in advance

Answer 1

This would work:

require(shiny)
require(ggplot2)

ui <- shinyUI(fluidPage(    
  tags$head(
    tags$script(
      HTML("
          // Get mouse coordinates
          var mouseX, mouseY;
          $(document).mousemove(function(e) {
              mouseX = e.pageX;
              mouseY = e.pageY;
          }).mouseover();

          // Function to possition draggable, place on current mouse coordinates
          Shiny.addCustomMessageHandler ('placeDraggable',function (message) {
                  var element = $('#hover_info').parent();
                  element.css({'top': mouseY + 'px', 'left' : mouseX + 'px'})
          });

          // Show or hide draggable
          Shiny.addCustomMessageHandler ('hideDraggable',function (message) {
            if(message.hide == true){
              $('#hover_info').parent().hide();
            } else{
              $('#hover_info').parent().show();
            }
          });
           ")
    )
  ),
  absolutePanel(fixed=TRUE, draggable = TRUE,
                verbatimTextOutput("hover_info")
  ),
  plotOutput("myplot",
             hover = hoverOpts(id ="myplot_hover")
  )
))

server <- shinyServer(function(input, output, session) {

  output$myplot <- renderPlot({
    ggplot(mtcars) + geom_point(aes(mpg,cyl))
  })

  # Create reactive variable
  points <- reactive({
    nearPoints(mtcars, input$myplot_hover,maxpoints=1)
  })

  # Define helper function
  hideTooltip <- function( hide ){
    session$sendCustomMessage(type = 'hideDraggable', message = list('hide'=hide))
  }

  observe({
    # Assign to local variable, not strictly necessary
    p <- points()

    if( nrow(p) == 0 ){ # Check if points is returning a point or empty data.frame
      hideTooltip(TRUE) # Hide tooltip if there's no info to show
      return()
    } 

    hideTooltip(FALSE) # Show tooltip if a point is returned from nearPoints
    session$sendCustomMessage(type = 'placeDraggable', message = list()) #Place draggable on current mouse position
    output$hover_info <- renderPrint({p}) # Render Text
  })

})

shinyApp(ui, server)

Here I'm simply placing the hover_info parent div on the current mouse position when the observer is fired and a point is returned.

Answer 2

This can be simplified quite a bit I think. Here I'm using clicking instead of hovering, but that can be changed based on taste of course.

require(shiny)
require(ggplot2)

ui <- shinyUI(fluidPage(    
  tags$head(
    tags$script(
      HTML("
           // Get mouse coordinates
           var mouseX, mouseY;
           $(document).mousemove(function(e) {
           mouseX = e.pageX;
           mouseY = e.pageY;
           }).mouseover();

           // Function to position draggable, place on current mouse coordinates
           Shiny.addCustomMessageHandler ('placeDraggable',function (message) {
           var element = $('#click_info').parent();
           element.css({'top': mouseY + 'px', 'left' : mouseX + 'px'})
           });
           ")
    )
  ),
  absolutePanel(fixed=TRUE, draggable = TRUE, uiOutput("click_info")),
  plotOutput("myplot", click = clickOpts(id ="myplot_click"))
))

server <- shinyServer(function(input, output, session) {

  output$myplot <- renderPlot({
    ggplot(mtcars) + geom_point(aes(mpg,cyl))
  })

  show_this  = reactiveVal(NULL)
  print_this = reactiveVal(NULL)
  observeEvent(input$myplot_click, {
    p <- nearPoints(mtcars, input$myplot_click, maxpoints=1)
    if( nrow(p) == 0 ) {
      show_this(NULL)
    }
    else {
      session$sendCustomMessage(type = 'placeDraggable', message = list())
      show_this(tagList(
        { actionButton("input_button","OK") },
        { br() },
        { verbatimTextOutput("point_info") }
      )
      )
      print_this({p})
    }
  })
  output$click_info <- renderUI   (show_this() )
  output$point_info <- renderPrint(print_this())

  observeEvent(input$input_button,{
    if (input$input_button) { show_this(NULL) }
  })

})

shinyApp(ui, server)

As you see, the whole hideDraggable is unnecssary, as well as the helper function and the points(). And the output is now outside of the observer, which is recommended.

Probably if you know a little bit of JavaScript (I don't!!!) it would be possible to also remove the placeDraggable function, and just specify that the #click_info element should always be placed according to the mouse coordinates. The shiny code makes sure it's only displayed when you want it to be.

Here I also included a little button with the displayed text just to show that you can use this as an opportunity to get more input from the user if needed. (Obviously then you need something more informative than just an OK button. For example, you could use this as a way to remove the point.)