Advertisement
Guest User

Untitled

a guest
Jul 16th, 2019
86
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 4.29 KB | None | 0 0
  1. require('shiny')
  2. require('ggplot2')
  3. require('DT')
  4. require('shinyjs')
  5.  
  6. ui <- pageWithSidebar(
  7.  
  8. headerPanel("Hover off the page"),
  9. sidebarPanel(width = 2
  10. ),
  11. mainPanel(
  12. shinyjs::useShinyjs(),
  13. tags$head(
  14. tags$style('
  15. #my_tooltip {
  16. position: absolute;
  17. pointer-events:none;
  18. width: 10;
  19. z-index: 100;
  20. padding: 0;
  21. font-size:10px;
  22. line-height:0.6em
  23. }
  24. ')
  25. ),
  26.  
  27. plotOutput('FP1Plot1' ,
  28. width = 1000,
  29. height = 800,
  30. hover = hoverOpts(id = 'FP1Plot_1_hover', delay = 0)
  31. ),
  32.  
  33. uiOutput("my_tooltip"),
  34. uiOutput("my_tooltip_style"),
  35. style = 'width:1250px'
  36. )
  37. )
  38.  
  39. server <- function(input, output, session) {
  40.  
  41. # ranges <- reactiveValues()
  42.  
  43.  
  44. output$FP1Plot1 <- renderPlot({
  45. ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() #+
  46. # coord_cartesian(xlim = ranges[[paste('FP1Plot1', 'x', sep = '')]],
  47. # ylim = ranges[[paste('FP1Plot1', 'y', sep = '')]]
  48. # )
  49. })
  50.  
  51.  
  52.  
  53.  
  54. # turn the hovers into 1 single reactive containing the needed information
  55. hoverReact <- reactive({
  56. ## in my real app I observer hover of all sub plots of all stages (7 pages with a multilot object)
  57. ## followed by code to store the page ID and plot NR as elements in hoverReact()
  58. hover <- input[['FP1Plot_1_hover']]
  59.  
  60. if(is.null(hover)) return(NULL)
  61. hover
  62.  
  63. })
  64.  
  65. ## debounce the reaction to calm down shiny
  66. hoverReact_D <- hoverReact %>% debounce(100) ## attempt to stop hoverData <- reactive({}) from firing too often, which is needed when you have 10k point scatter plots.....
  67.  
  68. hoverData <- reactive({
  69. hover <- hoverReact_D()
  70. if(is.null(hover)) return(NULL)
  71. ## 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
  72. hoverDF <- nearPoints(mtcars, coordinfo = hover, threshold = 15, maxpoints = 1, xvar = 'wt', yvar = 'mpg')
  73. hoverDF
  74. })
  75.  
  76.  
  77.  
  78. hoverPos <- reactive({
  79. ## here I look up the position information of the hover whenevver hoverReact_D and hoverData change
  80. hover <- hoverReact_D()
  81. hoverDF <- hoverData()
  82. if(is.null(hover)) return(NULL)
  83. if(nrow(hoverDF) == 0) return(NULL)
  84.  
  85. ## in my real app the data is already
  86. X <- hoverDF$wt[1]
  87. Y <- hoverDF$mpg[1]
  88.  
  89. left_pct <-
  90. (X - hover$domain$left) / (hover$domain$right - hover$domain$left)
  91.  
  92. top_pct <-
  93. (hover$domain$top - Y) / (hover$domain$top - hover$domain$bottom)
  94.  
  95. left_px <-
  96. (hover$range$left + left_pct * (hover$range$right - hover$range$left)) /
  97. hover$img_css_ratio$x
  98.  
  99. top_px <-
  100. (hover$range$top + top_pct * (hover$range$bottom - hover$range$top)) /
  101. hover$img_css_ratio$y
  102.  
  103. list(top = top_px, left = left_px)
  104. })
  105.  
  106.  
  107.  
  108.  
  109. observeEvent(hoverPos(), {
  110. req(hoverPos())
  111. hover <- hoverPos()
  112. if(is.null(hover)) return(NULL)
  113.  
  114.  
  115. offX <- if(hover$left > 350) {-400} else {30}
  116. offY <- if(hover$top > 350) {-290} else {10 }
  117.  
  118. print('sending css')
  119. print(offY)
  120.  
  121. runjs(paste0( "$(document).ready(function() {",
  122. "setTimeout(function(){",
  123. "$('[id^=FP1Plot]').mousemove(function(e) {",
  124. "$('#my_tooltip').show();",
  125. "$('#my_tooltip').css({",
  126. "top: (e.offsetY +", offY, " ) + 'px',",
  127. "left: (e.offsetX +", offX, ") + 'px'",
  128. "});",
  129. "});",
  130. "})});") )
  131.  
  132.  
  133. }, priority = -1)
  134.  
  135.  
  136. output$GGHoverTable <- DT::renderDataTable({
  137.  
  138. df <- hoverData()
  139. if(!is.null(df)) {
  140. if(nrow(df)){
  141. df <- df[1,]
  142. DT::datatable(t(df), colnames = rep("", nrow(df)),
  143. options = list(dom='t',ordering=F, autowidth = T))
  144. }
  145. }
  146. })
  147.  
  148.  
  149. output$my_tooltip <- renderUI({
  150. req(hoverData())
  151. req(nrow(hoverData())>0 )
  152. print('sending table')
  153. wellPanel(
  154. dataTableOutput('GGHoverTable'),
  155. style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
  156.  
  157. })
  158.  
  159.  
  160. }
  161.  
  162. shinyApp(ui, server)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement