r - Shiny :在 numericInput 中右键单击时提供上下文菜单？

Question

我被要求创建一些我不确定在 Shiny 中是否可行的东西:当用户右键单击数字输入时出现的上下文菜单。我知道如何在图表上显示上下文弹出窗口(请参阅下面的代码)，但这并不能帮助我回答以下问题:

• 输入小部件能否捕获点击/悬停/右键单击事件？
• 我可以在这种弹出窗口中生成一个 Shiny 菜单吗？

我很高兴收到类似“不可能”或“除非您今天学习所有 Javascript 否则不可能”的回答。如果是这样，我会想出另一种方法来将这种上下文相关的响应合并到界面中。

在点击图表时产生悬停窗口的示例代码:

library(shiny)

# Define UI for application that draws a histogram
ui <- fluidPage(

   # Application title
   titlePanel("Old Faithful Geyser Data"),

   # Sidebar with a slider input for number of bins 
   sidebarLayout(
      sidebarPanel(
         numericInput("bins",
                     "Number of bins:",
                     min = 1,
                     max = 50,
                     value = 30
                     )
      ),

      # Show a plot of the generated distribution
      mainPanel(
         plotOutput("distPlot", click = "plotclick"),
         uiOutput("plotClickInfo")
      )
   )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

   output$distPlot <- renderPlot({
      # generate bins based on input$bins from ui.R
      x    <- faithful[, 2] 
      bins <- seq(min(x), max(x), length.out = input$bins + 1)

      # draw the histogram with the specified number of bins
      hist(x, breaks = bins, col = 'darkgray', border = 'white')

   })

   output$plotClickInfo <- renderUI({
     click <- input$plotclick
     ## Find the KPI
     if (!is.null(click)){
       aText <- "More text"
       aLabel <- 'my label'
       # calculate point position INSIDE the image as percent of total dimensions
       # from left (horizontal) and from top (vertical)
       left_pct <- (click$x - click$domain$left) / (click$domain$right - click$domain$left)
       top_pct <- (click$domain$top - click$y) / (click$domain$top - click$domain$bottom)

       # calculate distance from left and bottom side of the picture in pixels
       left_px <- click$range$left + left_pct * (click$range$right - click$range$left)
       top_px <- click$range$top + top_pct * (click$range$bottom - click$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); max-width: 200px;",
                       "left:", left_px + 2, "px; top:", top_px + 2, "px;")

       # actual tooltip created as wellPanel
       wellPanel(
         style = style,
         p(HTML(paste0("<b> KPI: </b>", aLabel, "<br/>",
                       "<b> Information: </b>", aText)))
       )
     }
     else return(NULL)
   })

}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 1

你可以使用很棒的 shinyjs 包，它内置了很多事件监听器。看看他的文档 https://cran.r-project.org/web/packages/shinyjs/shinyjs.pdf .如果您想协调一些 jquery 事件，请看这里 http://api.jquery.com/category/events/mouse-events/

这里是其中一些您可能会觉得有用的示例，我认为右键单击是 mousedown 事件，但您可以查看

#onclick("bins", v$click <- rnorm(1))
#onevent("hover", "bins", v$click <- rnorm(1))
#onevent("dblclick", "bins", v$click <- rnorm(1))
onevent("mousedown", "bins", v$click <- rnorm(1))

代码:

library(shiny)
library(shinyjs)

# Define UI for application that draws a histogram
ui <- fluidPage(
  useShinyjs(),
  # Application title
  titlePanel("Old Faithful Geyser Data"),

  # Sidebar with a slider input for number of bins 
  sidebarLayout(
    sidebarPanel(
      numericInput("bins","Number of bins:",min = 1,max = 50,value = 30),
      uiOutput("plotClickInfo")
    ),

    # Show a plot of the generated distribution
    mainPanel(
      plotOutput("distPlot", click = "plotclick")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

  output$distPlot <- renderPlot({
    # generate bins based on input$bins from ui.R
    x    <- faithful[, 2] 
    bins <- seq(min(x), max(x), length.out = input$bins + 1)

    # draw the histogram with the specified number of bins
    hist(x, breaks = bins, col = 'darkgray', border = 'white')

  })

  v <- reactiveValues()


  #onclick("bins", v$click <- rnorm(1))
  #onevent("hover", "bins", v$click <- rnorm(1))
  #onevent("dblclick", "bins", v$click <- rnorm(1))
  onevent("mousedown", "bins", v$click <- rnorm(1))

  output$plotClickInfo <- renderUI({
    if (!is.null(v$click)){
      aText <- "More text"
      aLabel <- paste0('my label - ',v$click)
      wellPanel(
        p(HTML(paste0("<b> KPI: </b>", aLabel, "<br/>","<b> Information: </b>", aText)))
      )
    }
    else return(NULL)
  })

}

# Run the application 
shinyApp(ui = ui, server = server)