Modularized Shiny: теги в стиле HTML не работают для всплывающей подсказки - PullRequest
Новая
       70

Modularized Shiny: теги в стиле HTML не работают для всплывающей подсказки

0 голосов
/ 04 января 2019

Привет, спасибо за любую помощь заранее.

Я разрабатываю приложение Shiny для EDA и хочу добавить всплывающую подсказку на диаграмму рассеяния ggplot.

Этот пример работает нормально до тех пор, пока оси не будут преобразованы в лог, поскольку координаты всплывающей подсказки находятся за пределами диапазона графика.

Пример 3 в этом ответе работает с диаграммой рассеяния, преобразованной в журнал, но когда я использую ее в модуле Shiny, элементы tags$style и tags$script не передаются объекту пользовательского интерфейса всплывающей подсказки my_tooltip и фактический текст во всплывающей подсказке. Я подозреваю, что когда на my_tooltip ссылаются в tags$style, пространство имен не учитывается, поэтому my_tooltip никогда не использует элемент HTML.

Я не знаю достаточно HTML, чтобы редактировать Пример 3. Ниже я приведу три воспроизводимых примера, измененных из двух источников, указанных выше, которые все являются частью того, чего я хочу достичь. Любая помощь будет оценена. Благодарю.

Воспроизводимый пример 1: работает с логарифмическим масштабом, но не в блестящем модуле 

library(shiny)
library(ggplot2)

ui <- fluidPage(

  selectInput("logX", "Log scale",
              choices=coordoptions,
              selected="identity"),
  selectInput("logY", "Log scale",
              choices=coordoptions,
              selected="identity"),

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

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

              // ID of uiOutput
              $("#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("distPlot", hover = "plot_hover", hoverDelay = 0),
  uiOutput("my_tooltip")

  )

server <- function(input, output) {

      output$distPlot <- renderPlot({
    req(input$var_y)
    ggplot(iris, aes_string("Sepal.Width", input$var_y)) + 
      geom_point() +
      scale_x_continuous(trans=input$logX) + 
      scale_y_continuous(trans=input$logY) 
  })

  output$my_tooltip <- renderUI({
    hover <- input$plot_hover 
    y <- nearPoints(iris, input$plot_hover)[input$var_y]
    req(nrow(y) != 0)
    verbatimTextOutput("vals")
  })

  output$vals <- renderPrint({
    hover <- input$plot_hover 
    y <- nearPoints(iris, input$plot_hover)[input$var_y]
    req(nrow(y) != 0)
    y
  })  
}

shinyApp(ui = ui, server = server)

Воспроизводимый пример 2: работает без преобразования, но всплывающая подсказка выходит за пределы диапазона с преобразованиями журнала 

library("shiny")
library("ggplot2")

ui <- pageWithSidebar(
  headerPanel("Tooltips in ggplot2 + shiny"),

  sidebarPanel(
    selectInput("logX", "Log scale",
                choices=coordoptions,
                selected="identity"),
    selectInput("logY", "Log scale",
                choices=coordoptions,
                selected="identity"),
    width = 3
  ),

  mainPanel(

    # this is an extra div used ONLY to create positioned ancestor for tooltip
    # we don't change its position
    div(
      style = "position:relative",
      plotOutput("scatterplot", 
                 hover = hoverOpts("plot_hover", delay = 100, delayType = "debounce")),
      uiOutput("hover_info")
    ),
    width = 7
  )
)

server <- function(input, output) {

  output$scatterplot <- renderPlot({
    ggplot(mtcars, aes(x = mpg, y = hp)) +
      geom_point() +
      scale_x_continuous(trans=input$logX) + 
      scale_y_continuous(trans=input$logY) 
  })


  output$hover_info <- renderUI({
    hover <- input$plot_hover
    point <- nearPoints(mtcars, hover, threshold = 5, maxpoints = 1, addDist = TRUE)
    if (nrow(point) == 0) return(NULL)

    # calculate point position INSIDE the image as percent of total dimensions
    # from left (horizontal) and from top (vertical)
    left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left)
    top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom)

    # calculate distance from left and bottom side of the picture in pixels
    left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
    top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)

    # create style property fot tooltip
    # background color is set so tooltip is a bit transparent
    # z-index is set so we are sure are tooltip will be on top
    style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
                "left:", left_px + 2, "px; top:", top_px + 2, "px;")

    # actual tooltip created as wellPanel
    wellPanel(
      style = style,
      p(HTML(paste0("<b> Car: </b>", rownames(point), "<br/>",
                    "<b> mpg: </b>", point$mpg, "<br/>",
                    "<b> hp: </b>", point$hp, "<br/>",
                    "<b> Distance from left: </b>", left_px, "<b>, from top: </b>", top_px)))
    )
  })
}

runApp(list(ui = ui, server = server))

Воспроизводимый пример 3: работает с логарифмическими масштабами и в модуле, но tags$style не работает для my_tooltip (без всплывающего графика) 

library(shiny)
library(ggplot2)

AUI<-function(id){

  ns<-NS(id)

  fluidPage(

    selectInput(ns("logX"), "Log scale",
                choices=coordoptions,
                selected="identity"),
    selectInput(ns("logY"), "Log scale",
                choices=coordoptions,
                selected="identity"),

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

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

              // ID of uiOutput
              $("#my_tooltip").show();         
              $("#my_tooltip").css({             
              top: (e.pageY + 5) + "px",             
              left: (e.pageX + 5) + "px"         
              });     
              });     
              });
              '),

    selectInput(ns("var_y"), "Y-Axis", choices = names(iris)),
    plotOutput(ns("distPlot"), hover = ns("plot_hover"), hoverDelay = 0),
    uiOutput(ns("my_tooltip"))

  )
}  


A <- function(input, output, session) {

  ns<-session$ns

  output$distPlot <- renderPlot({
    req(input$var_y)
    ggplot(iris, aes_string("Sepal.Width", input$var_y)) + 
      geom_point() +
      scale_x_continuous(trans=input$logX) + 
      scale_y_continuous(trans=input$logY) 
  })

  output$my_tooltip <- renderUI({
    hover <- input$plot_hover 
    y <- nearPoints(iris, input$plot_hover)[input$var_y]
    req(nrow(y) != 0)
    verbatimTextOutput(ns("vals"))
  })

  output$vals <- renderPrint({
    hover <- input$plot_hover 
    y <- nearPoints(iris, input$plot_hover)[input$var_y]
    req(nrow(y) != 0)
    y
  })  
}

ui<-AUI("id")

server <- function(input, output, session){
      callModule(A, "id")
}


shinyApp(ui = ui, server = server)
...