Question

Я экспериментирую с кодом для всплывающих сообщений поверх объектов ggplot2, и пока он работает довольно хорошо, за исключением того, что теперь я боюсь, что следующая задача выходит за рамки моих навыков:

В приложении, гдеУ меня будет около 6–72 похожих ggplots, распределенных по разным страницам в моем приложении, и я хотел бы иметь возможность автоматически присоединять JavaScript ко всем этим элементам: то есть перейти от сценария с одним тегом $ к универсальному решению, которое работает для всехplots

Я пытался создать новую функцию 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
}

но я получаю сообщение об ошибке:

input $ children [[2]]: индекс за пределами границ

Идеязатем нужно вызвать это:

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

и JavaScript (незаконченный) должен выглядеть примерно так, но вместо #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 для одного графика (верхний из двух), выглядит следующим образом:

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». Субплоты в одной группе получат serialnr, т. е .: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)

Stéphane Laurent · Answer 1 · 04 мая 2019

Я не понимаю общий контекст, но, возможно, это поможет:

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)

Как добавить пользовательскую функцию наведения на plotOutput, чтобы ее можно было использовать для многих графиков

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Обновление

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Как добавить пользовательскую функцию наведения на plotOutput, чтобы ее можно было использовать для многих графиков

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Обновление

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Похожие темы