代码之家  ›  专栏  ›  技术社区  ›  Mark

如何在绘图输出中添加自定义悬停函数,使其可用于许多绘图

hover shiny ggplot2 r javascript
  •  0
  • Mark  · 技术社区  · 5 年前

    我正在试验在ggplot2对象上悬停消息的一些代码, 到目前为止,它工作得很好,除了现在我担心以下挑战超出了我的技能范围:

    在一个应用程序中,我的应用程序中有6到72个类似的ggplots分布在不同的页面上,我希望能够自动将hover javascript附加到所有页面上:即从单个标记$script更改为适用于所有绘图的通用解决方案

    我试图构建一个新的plotoutput2函数,但我根本无法使它工作。 

    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
}

    但我得到一个错误,它说:

    输入$children[[2]]:下标越界

    我们的想法是称之为: 

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

    而javascript(未完成)需要看起来像这样,但是创建唯一的输出ID而不是 #my_tooltip 其中包含 plotname + tooltip :即: #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'",         
  "});",     
  "});",   
  "}"
)

    在用户界面中使用以下行 

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

    只有一个预编好的javascript悬停弹出窗口用于一个绘图(两个图中的前一个)的应用程序如下所示:

    screenshot 

    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)

    根据初始答案编辑:

    我的应用程序中(目前)有7组绘图, 每个图名将以标识组的名称开始(每个组使用不同的数据帧):在示例2中,组为:“fp1plot”和“cleanfp1”。 一组中的子批次将得到一个序列号 即:“fp1plot_1”、“fp1plot_2”、“cleanfp1_1”、“cleanfp1_2”

    我试图重写 hovers <- .... 为了使其成为可能大量(>100)绘图的容易生成的列表,并在if语句构造中查找所需的数据帧, 但在这一点上,悬停没有反应 

    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)
    0 回复  |  直到 5 年前
        1
  •  1
  •   Stéphane Laurent    5 年前

    我不了解一般情况,但这可能有助于: 

    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)

    更新 

    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)
    推荐文章
    Shawn Hemelstrand  ·  为什么我的自定义errorbar函数不能在R中工作?
    2 年前
    Jeff238  ·  为scale\u fill\u连续比例而不是离散比例制作图例
    2 年前
    jerH  ·  从ggplot bar plot中省略一些数据标签
    2 年前
    Stefan  ·  当facet\u wrap()中的比例设置为“free”时,如何增加ggplot中的默认y轴限制
    2 年前
    Honorato  ·  在图形图例中插入两列数据-ggplot2
    2 年前
    Naota Feykneme  ·  你能在R中分别控制散点图点的宽度和高度吗?[副本]
    2 年前
    Shawn Hemelstrand  ·  如何在ggplot中的许多回归线中为一条特定回归线上色以匹配注释?
    2 年前
    Jenny  ·  如何在ggplot2轴上重新排序类别
    2 年前
    Kirds  ·  在ggplot中将国家名称添加到地图中
    2 年前
    MadelineJC  ·  group_by在R中按顺序排列数字
    2 年前
    关于   移动版
    代码之家 - 一站式码农服务社区
    沪ICP备11025650号