I'm experimenting with some code for hover messages on top of ggplot2 objects, and so far it is working quite well, except now the following challenge goes beyond my skills I fear:

In an App where I will have about 6 to 72 similar ggplots spread over various pages in my app, I would like to be able to attach the hover javascript to all of them automatically: i.e. change from a single tags$script to a generic solution that works for all plots

I tried to build a new plotOutput2 function but I can't get it to work at all.

plotOutput2 <- function(outputId, width = "100%", height = "400px", click = NULL, 
                        dblclick = NULL, hover = NULL, hoverDelay = NULL, hoverDelayType = NULL, 
                        brush = NULL, clickId = NULL, hoverId = NULL, inline = FALSE,
                        onhover) {
    input <- plotOutput(outputId, width, height, click, dblclick, 
                         hover, hoverDelay, hoverDelayType, brush, clickId, hoverId, inline)
    attribs <- c(input$children[[2]]$attribs, onhover = onhover)
    input$children[[2]]$attribs <- attribs
    input
}

but I get an error that says:

input$children[[2]] : subscript out of bounds

The idea is to then call this:

plotOutput2("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0), onhover = "hoverJS(this.id)"),

and the javascript (unfinished) needs to look something like this but create unique output ids instead of #my_tooltip that contain the plotname + tooltip: i.e.: #distPlot_tooltip

hoverjs <- c(
  "function hoverJS(id){",
  "document.getElementById(id).mousemove(function(e) {", 
  "$('#my_tooltip').show();",
  "$('#my_tooltip').css({",             
  "top: (e.pageY + 5) + 'px',",             
  "left: (e.pageX + 5) + 'px'",         
  "});",     
  "});",   
  "}"
)

with the following line in the UI

tags$script(HTML(hoverjs)),  ## to add the javascript to the app

The app with only a single precoded javascript hover popup for one plot (top one of the two) looks like this:

library(shiny)
library(ggplot2)
# put function plotOutput2 here
# put hoverJS code here 

ui <- fluidPage(

  tags$head(tags$style('
     #my_tooltip {
      position: absolute;
      width: 300px;
      z-index: 100;
      padding: 0;
     }
  ')),

  tags$script('
    $(document).ready(function() {
      // id of the plot
      $("#ploty").mousemove(function(e) { 

        // ID of uiOutput
        $("#my_tooltip").show();         
        $("#my_tooltip").css({             
          top: (e.pageY + 5) + "px",             
          left: (e.pageX + 5) + "px"         
        });     
      });     
    });
  '),
  #tags$script(HTML(hoverjs)), 
  selectInput("var_y", "Y-Axis", choices = names(iris)),
  plotOutput("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0)),
  plotOutput("plotx", hover = hoverOpts(id = "plotx_hover", delay = 0)), 
  uiOutput("my_tooltip")


)

server <- function(input, output) {


  output$ploty <- renderPlot({
    req(input$var_y)
    ggplot(iris, aes_string("Sepal.Width", input$var_y)) + 
      geom_point()
  })
  output$plotx <- renderPlot({
    req(input$var_y)
    ggplot(mtcars, aes_string("mpg", 'hp')) + 
      geom_point()
  })
  output$my_tooltip <- renderUI({
    hover <- input$ploty_hover 
    y <- nearPoints(iris, input$ploty_hover)
    req(nrow(y) != 0)
    wellPanel(DT::dataTableOutput("vals"), style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
  })

  output$vals <- DT::renderDataTable({
    hover <- input$ploty_hover 
    y <- nearPoints(iris, input$ploty_hover)
    req(nrow(y) != 0)
    DT::datatable(t(y), colnames = rep("", ncol(t(y))), options = list(dom = 't', searching = F, bSort = FALSE))
  })  
}
shinyApp(ui = ui, server = server)

EDIT based on initial answer:

I will have (currently) 7 groups of plots in my app, each plot name will start with a name identifying the group (each group uses a different data frame): in the example 2 groups: 'FP1Plot' and 'CleanFP1' The subplots within one group will get a serialnr i.e.: 'FP1Plot_1', 'FP1Plot_2', 'CleanFP1_1', 'CleanFP1_2'

I have tried to rewrite the hovers <- .... to make it a easily generated list for the possible huge (>100) number of plots, and will look up the needed dataframe in an if statement construction, but at this point the hover doesn't react

require('shiny')
require('ggplot2')
require('shinyjqui')

mtcars <- as.data.table(mtcars)
max_plots <- 12;

ui <- pageWithSidebar(

  headerPanel("Dynamic number of plots"),
  sidebarPanel(width = 2, sliderInput("n", "Number of plots", value=5, min=1, max=max_plots),
               h4('click points to see info'),
               h4('select area to zoom'),
               h4('Double click to unzoom')
  ),
  mainPanel(
    tags$head(
      tags$style('
#my_tooltip {
  position: absolute;
  pointer-events:none;
  width: 300px;
  z-index: 100;
  padding: 0;
}'),
      tags$script('
$(document).ready(function() {
  $("[id^=plot]").mousemove(function(e) { 
    $("#my_tooltip").show();         
    $("#my_tooltip").css({             
      top: (e.pageY + 5) + "px",             
      left: (e.pageX + 5) + "px"         
    });     
  });     
});')
    ),

    tabsetPanel(
    tabPanel('fp1',
        uiOutput("FP1Plotmultiplots")
      ),
    tabPanel('clean',
      uiOutput("CleanFP1multiplots") 
    )
    ),
    style = 'width:1250px'
  )
)

server <- function(input, output, session) {
  plotlist <- c('FP1Plot', 'CleanFP1')

  ranges <- reactiveValues()

  # make the individual plots
  observe({
    lapply(1:input$n, function(i){
      plotname <- paste0('FP1Plot', i)
      output[[plotname]] <- renderPlot({
        ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
          coord_cartesian(xlim =ranges[[paste('FP1Plot', i, 'x', sep = '')]], 
                          ylim = ranges[[paste('FP1Plot', i, 'y', sep = '')]]
          ) +
          theme_classic() +
          theme(legend.text=element_text(size=12), 
                legend.title=element_blank(),
                legend.position = 'bottom') 
      })
    })
  })

  observe({
    lapply(1:input$n, function(i){
      plotname <- paste0('CleanFP1', i)  
      output[[plotname]] <- renderPlot({
        ggplot(iris, aes(iris[ ,ncol(iris)-1], iris[ ,i], color = as.factor(Species))) + geom_point() +
          coord_cartesian(xlim =ranges[[paste('CleanFP1', i, 'x', sep = '')]], 
                          ylim = ranges[[paste('CleanFP1', i, 'y', sep = '')]]
          ) +
          theme_classic() +
          theme(legend.text=element_text(size=12), 
                legend.title=element_blank(),
                legend.position = 'bottom') 
      })
    })
  })

  # make the divs with plots and buttons etc  
  lapply(plotlist, function(THEPLOT) { 
  output[[paste(THEPLOT, 'multiplots', sep = '')]] <- renderUI({
    plot_output_list <- list()
    n <- input$n

    n_cols <- if(n == 1) {
      1
    } else if (n %in% c(2,4)) {
      2
    } else if (n %in% c(3,5,6,9)) {
      3
    } else {
      4
    }
    Pwidth <- 900/n_cols
    Pheigth <- 500/ceiling(n/n_cols) # calculate number of rows
    Pwidth2 <- Pwidth+40
    Pheigth2 <-Pheigth+40 

    plot_output_list <- list();

    for(i in 1:input$n) {
      plot_output_list <- append(plot_output_list,list(
        div(id = paste0('div', THEPLOT, i),
            wellPanel(
              plotOutput(paste0(THEPLOT, i), 
                         width = Pwidth, 
                         height = Pheigth,
                         hover = hoverOpts(id = paste(THEPLOT, i, "hover", sep = '_'), delay = 0)
                         # click = paste0(THEPLOT, i, '_click'),
                         # dblclick =  paste0(THEPLOT, i, '_dblclick'),
                         # brush = brushOpts(
                         #   id =  paste0(THEPLOT, i, '_brush'),
                         #   resetOnNew = TRUE
                         # )
              ), 
              style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:',  Pwidth2, 'px; height:', Pheigth2, 'px', sep = '')),
            style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = ''))

      ))
    }
    do.call(tagList, plot_output_list)
  })

  })

  eg <- expand.grid(plotlist, 1:max_plots) 

  tooltipTable <- reactive({

    ## attempt to make this work for the large amount of plots in my app
    hovers <- as.list(sapply(c(sprintf('%s_%s', eg[,1], eg[,2])), function(key) key = eval(parse(text = paste('input$', key, '_hover', sep = ''))) )) 

    notNull <- sapply(hovers, Negate(is.null))
    if(any(notNull)){
      plotid <- names(which(notNull))
      plothoverid <- paste0(plotid, "_hover")
      dataset <- if(grepl('FP1Plot', plotid)) { mtcars } else { iris } 
      ## I will add some code here based on the plot nr to grab the needed columns for the x and y data of the specific plot, since the list of x and y columns will be stored in two vectors:
      ## 1 vector with x parameter 1:12, and 1 for y. 
      ## every group of plots will use the same list of selected x and y parameters 
      # (or if I switch to plot group specific lists, the lists will contain the group names just like the plots, so I can link them by name here)
      y <- nearPoints(dataset, input[[plothoverid]], 
                      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)

标签： javascript r ggplot2 shiny hover

1条回答

贼婆χ

2楼-- · 2019-07-26 02:32

I don't understand the general context, but maybe this can help:

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

ui <- fluidPage(

  tags$head(
    tags$style('
#my_tooltip {
  position: absolute;
  pointer-events:none;
  width: 300px;
  z-index: 100;
  padding: 0;
}'),
  tags$script('
$(document).ready(function() {
  $("[id^=plot]").mousemove(function(e) { 
    $("#my_tooltip").show();         
    $("#my_tooltip").css({             
      top: (e.pageY + 5) + "px",             
      left: (e.pageX + 5) + "px"         
    });     
  });     
});')
  ),

  selectInput("var_y", "Y-Axis", choices = names(iris)),
  plotOutput("ploty", hover = hoverOpts(id = "ploty_hover", delay = 0)),
  plotOutput("plotx", hover = hoverOpts(id = "plotx_hover", delay = 0)), 
  uiOutput("my_tooltip")
)

datasets <- list(plotx = mtcars, ploty = iris)

server <- function(input, output) {

  output$ploty <- renderPlot({
    req(input$var_y)
    ggplot(iris, aes_string("Sepal.Width", input$var_y)) + geom_point()
  })
  output$plotx <- renderPlot({
    ggplot(mtcars, aes_string("mpg", 'hp')) + geom_point()
  })

  tooltipTable <- reactive({
    hovers <- list(plotx = input$plotx_hover, ploty = input$ploty_hover)
    notNull <- sapply(hovers, Negate(is.null))
    if(any(notNull)){
      plotid <- names(which(notNull))
      plothoverid <- paste0(plotid, "_hover")
      y <- nearPoints(datasets[[plotid]], input[[plothoverid]], 
                      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 = ui, server = server)

Update

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

#mtcars <- as.data.table(mtcars)
max_plots <- 12;

ui <- pageWithSidebar(

  headerPanel("Dynamic number of plots"),
  sidebarPanel(width = 2, sliderInput("n", "Number of plots", value=5, min=1, max=max_plots),
               h4('click points to see info'),
               h4('select area to zoom'),
               h4('Double click to unzoom')
  ),
  mainPanel(
    tags$head(
      tags$style('
                 #my_tooltip {
                 position: absolute;
                 pointer-events:none;
                 width: 300px;
                 z-index: 100;
                 padding: 0;
                 }'),
      tags$script('
                  $(document).ready(function() {
                  setTimeout(function(){
                  $("[id^=FP1Plot],[id^=CleanFP1]").mousemove(function(e) { 
                  $("#my_tooltip").show();         
                  $("#my_tooltip").css({             
                  top: (e.offsetY) + "px",             
                  left: (e.pageX + 5) + "px"         
                  });     
                  });     
                  },5000)});')
    ),

    tabsetPanel(
      tabPanel('fp1',
               div(style = "position:relative",
                   uiOutput("FP1Plotmultiplots"))
      ),
      tabPanel('clean',
               uiOutput("CleanFP1multiplots") 
      )
    ),
    uiOutput("my_tooltip"),
    style = 'width:1250px'
  )
)

server <- function(input, output, session) {
  plotlist <- c('FP1Plot', 'CleanFP1')

  ranges <- reactiveValues()

  # make the individual plots
  observe({
    lapply(1:input$n, function(i){
      plotname <- paste0('FP1Plot', i)
      output[[plotname]] <- renderPlot({
        ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
          coord_cartesian(xlim =ranges[[paste('FP1Plot', i, 'x', sep = '')]], 
                          ylim = ranges[[paste('FP1Plot', i, 'y', sep = '')]]
          ) +
          theme_classic() +
          theme(legend.text=element_text(size=12), 
                legend.title=element_blank(),
                legend.position = 'bottom') 
      })
    })
  })

  observe({
    lapply(1:input$n, function(i){
      plotname <- paste0('CleanFP1', i)  
      output[[plotname]] <- renderPlot({
        x <- names(iris)[ncol(iris)-1]
        y <- names(iris)[i]
        ggplot(iris, aes_string(x, y, color = "Species")) + geom_point() +
          coord_cartesian(xlim =ranges[[paste('CleanFP1', i, 'x', sep = '')]], 
                          ylim = ranges[[paste('CleanFP1', i, 'y', sep = '')]]
          ) +
          theme_classic() +
          theme(legend.text=element_text(size=12), 
                legend.title=element_blank(),
                legend.position = 'bottom') 
      })
    })
  })

  # make the divs with plots and buttons etc  
  lapply(plotlist, function(THEPLOT) { 
    output[[paste(THEPLOT, 'multiplots', sep = '')]] <- renderUI({
      plot_output_list <- list()
      n <- input$n

      n_cols <- if(n == 1) {
        1
      } else if (n %in% c(2,4)) {
        2
      } else if (n %in% c(3,5,6,9)) {
        3
      } else {
        4
      }
      Pwidth <- 900/n_cols
      Pheigth <- 500/ceiling(n/n_cols) # calculate number of rows
      Pwidth2 <- Pwidth+40
      Pheigth2 <- Pheigth+40 

      plot_output_list <- list();

      for(i in 1:input$n) {
        plot_output_list <- append(plot_output_list,list(
          div(id = paste0('div', THEPLOT, i),
              wellPanel(
                plotOutput(paste0(THEPLOT, i), 
                           width = Pwidth, 
                           height = Pheigth,
                           hover = hoverOpts(id = paste(THEPLOT, i, "hover", sep = '_'), delay = 0)
                           # click = paste0(THEPLOT, i, '_click'),
                           # dblclick =  paste0(THEPLOT, i, '_dblclick'),
                           # brush = brushOpts(
                           #   id =  paste0(THEPLOT, i, '_brush'),
                           #   resetOnNew = TRUE
                           # )
                ), 
                style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:',  Pwidth2, 'px; height:', Pheigth2, 'px', sep = '')),
              style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheigth2, 'px', sep = ''))

        ))
      }
      do.call(tagList, plot_output_list)
    })

  })

  eg <- expand.grid(plotlist, 1:max_plots) 
  plotids <- sprintf('%s_%s', eg[,1], eg[,2])
  names(plotids) <- plotids

  tooltipTable <- reactive({
    hovers <- 
      lapply(plotids, function(key) input[[paste0(key, '_hover')]])

    notNull <- sapply(hovers, Negate(is.null))
    if(any(notNull)){
      plotid <- names(which(notNull))
      plothoverid <- paste0(plotid, "_hover")
      dataset <- if(grepl('FP1Plot', plotid)) { mtcars } else { iris } 
      ## I will add some code here based on the plot nr to grab the needed columns for the x and y data of the specific plot, since the list of x and y columns will be stored in two vectors:
      ## 1 vector with x parameter 1:12, and 1 for y. 
      ## every group of plots will use the same list of selected x and y parameters 
      # (or if I switch to plot group specific lists, the lists will contain the group names just like the plots, so I can link them by name here)
      y <- nearPoints(dataset, input[[plothoverid]], 
                      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)

0人赞添加讨论(0) 举报

How to add custom hover function to plotOutput so

Update

采纳回答

编辑标签

举报内容

检举类型

检举原因

检举说明(必填)

打开微信“扫一扫”，打开网页后点击屏幕右上角分享按钮

付费偷看金额在0.1-10元之间