时间戳

首页 > 解决方案 > 如何防止ggplot hoverOpts消息使用css离开屏幕

css - 如何防止ggplot hoverOpts消息使用css离开屏幕

问题描述

在运行下面的演示应用程序时，我遇到的问题是情节底部的悬停消息最终会从屏幕上消失。

有谁知道是否有办法调整位置，使整个消息始终落在屏幕边界（l，r，t，b）内？

在此处输入图像描述

require('shiny')
require('ggplot2')
library(DT)

ui <- pageWithSidebar(

  headerPanel("Hover off the page"),
  sidebarPanel(width = 2
  ),
  mainPanel(
    tags$head(
      tags$style('
                 #my_tooltip {
                 position: absolute;
                 pointer-events:none;
                 z-index: 1;
                 padding: 0;
                 }'),
      tags$script('
                  $(document).ready(function() {
                  setTimeout(function(){
                  $("[id^=FP1Plot]").mousemove(function(e) { 
                  $("#my_tooltip").show();         
                  $("#my_tooltip").css({             
                  top: (e.offsetY) + "px",             
                  left: (e.pageX -300) + "px"         
                  });     
                  });     
                  },1000)});')
    ),

                   plotOutput('FP1Plot1' ,
                              width = 1000,
                              height = 800,
                              hover = hoverOpts(id = 'FP1Plot1_hover', delay = 0)          
      ),

    uiOutput("my_tooltip"),
    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 = '')]]
          )          
      })





  tooltipTable <- reactive({
      y <- nearPoints(mtcars, input$FP1Plot1_hover, 
                      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)

标签： cssrshinyhovermousemove

解决方案

@ stephane，我想出了另一个解决方案，使用“发送css”代码来更新悬停消息的位置。我仍然遇到的唯一问题是，在消息内容第二次更改到象限中的某个点之前，位置不会更新。

x 偏移有 2 个值，y 偏移有 2 个值，实际上将绘图分成 4 个象限。切换到另一个象限会将消息置于最后一个象限配置中，并且直到我将鼠标悬停在新象限的第二个点上才更正此问题。

您有什么想法可以更有效地推动 CSS 更改吗？也许用 sendcustommessage 左右？我试图那样做，但用这种方法根本无法让它工作。到目前为止，这是我的代码尝试：

require('shiny')
require('ggplot2')
require('DT')

ui <- pageWithSidebar(

  headerPanel("Hover off the page"),
  sidebarPanel(width = 2
  ),
  mainPanel(
    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)
  })



  output$my_tooltip_style <- renderUI({
    req(hoverPos())
    hover <- hoverPos()
    if(is.null(hover)) return(NULL)

    print(hover$top)
    offX <- if(hover$left  > 350) {-400} else {30}
    offY <- if(hover$top  > 350) {-290} else {10 }

    print(paste(offX, offY))

    cssMessage <- paste( "
                    $(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'        
                         });     
                         });     
                         })});", sep = '')

    tags$script(cssMessage)

})




  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())
    wellPanel(
      dataTableOutput('GGHoverTable'),
      style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
  })


}

shinyApp(ui, server)

推荐阅读