如何防止ggplot hoverOpts消息使用CSS离开屏幕 [英] How to prevent ggplot hoverOpts messages to go off screen with css

问题描述

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

有人知道是否有一种方法可以调整位置，以使整个消息始终位于屏幕边界（l，r，t，b）之内？

  require（'shiny'）
 require（'ggplot2'）
库（DT）
 
 ui<-pageWithSidebar（
 
 headerPanel（悬停在页面上），
 sidebarPanel（width = 2 
），
 mainPanel（
 tags $ head（
 tags $ style（'
＃ my_tooltip {
位置：绝对； 
指针事件：无； 
 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，剩余
：（e.pageX -300）+ px 
}）; 
}）； 
}，1000）}）;'）
），
 
 plotOutput（'FP1Plot1'，
宽度= 1000，
高度= 800，
悬停= hoverOpts（id ='FP1Plot1_hover'，延迟= 0）
），
 
 uiOutput（ my_tooltip），
 style ='width：1250px'
）
）
 
服务器<-函数（输入，输出，会话）{
 
范围<--reactValues（）
 
 
 output $ FP1Plot1<-renderPlot（{
 ggplot（mtcars，aes（wt，mpg，color = as.factor（cyl）））+ geom_point（）+ 
 coord_cartesian （xlim = range [[paste（'FP1Plot1'，'x'，sep =''）]]，
 ylim = range [[paste（'FP1Plot1'，'y'，sep =''）]]] 
）
}）
 
 
 
 
 
 tooltipTable<-react（{
y<-nearPoints （mtcars，输入$ FP1Plot1_hover，
阈值= 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;内边距：10px; width：400px; border-color：＃339fff'）
}）
 
 output $ vals<-renderDT（{
 tooltipTable（）
}）
 
 
} 
 
 ShinyApp（ui，服务器）
  

解决方案

以下是JS库

When running the demo App below, the problem I run into is that hover messages for the bottom part of the plot end up running off the screen.

Does anybody know if there is a way to adjust the position so that the entire message always falls within the screen boundaries (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)

解决方案

Here is a solution with the JS library qTip2.

library(shiny)
library(ggplot2)
library(DT)

js_qTip <- "
$('#hoverinfo').qtip({
  overwrite: true,
  content: {
    text: $('#tooltip').clone()
  },
  position: {
    my: '%s',
    at: '%s',
    target: [%s,%s],
    container: $('#FP1Plot1')
  },
  show: {
    ready: true
  },
  hide: {
    target: $('#FP1Plot1')
  },
  style: {
    classes: 'qtip-light'
  }
});
"

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(
      HTML(
        'Shiny.addCustomMessageHandler("jsCode", function(mssg){setTimeout(function(){eval(mssg.value);},10);})'
      )
    )
  ),
  plotOutput('FP1Plot1' ,
             width = 1000,
             height = 700,
             hover = hoverOpts(id = 'FP1Plot1_hover')),
  tags$div(id = "hoverinfo", style = "position: absolute;"),
  tags$div(DTOutput("tooltip"), style = "visibility: hidden;") # put this div at the very end of the UI
)

server <- function(input, output, session){
  output$FP1Plot1 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point(size = 2)
  })

  tooltipTable <- eventReactive(input[["FP1Plot1_hover"]], { 
    hover <- input[["FP1Plot1_hover"]]
    if(is.null(hover)) return(NULL)
    dat <- mtcars
    point <- nearPoints(dat, hover, threshold = 15, maxpoints = 1)
    if(nrow(point) == 0) return(NULL)
    X <- point[["wt"]]
    Y <- point[["mpg"]]
    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 
    pos <- ifelse(left_pct<0.5,
                  ifelse(top_pct<0.5, 
                         "top left",
                         "bottom left"),
                  ifelse(top_pct<0.5,
                         "top right",
                         "bottom right"))
    list(data = t(point), pos = pos, left_px = left_px+10, top_px = top_px)
  }) # end of eventReactive

  output[["tooltip"]] <- renderDT({
    req(tooltipTable())
    datatable(tooltipTable()$data, colnames = NULL, 
              options = list(dom = "t", ordering = FALSE))
  }, server = FALSE)

  observeEvent(tooltipTable(), {
    tt <- tooltipTable()
    session$sendCustomMessage(
      type = "jsCode", 
      list(value = sprintf(js_qTip, tt$pos, tt$pos, tt$left_px, tt$top_px))
    )
  })
}

shinyApp(ui, server)

这篇关于如何防止ggplot hoverOpts消息使用CSS离开屏幕的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！