Shiny：在 numericInput 中右键单击时提供上下文菜单？答案

【问题标题】：Shiny: Provide context menu on right click in numericInput?Shiny：在 numericInput 中右键单击时提供上下文菜单？
【发布时间】：2018-06-17 10:43:56
【问题描述】：

我被要求创建一些我不确定在 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)

【问题讨论】：

标签： r shiny

【解决方案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)

【讨论】：

非常感谢。这非常有帮助，并允许我创建一个位于“信息”图像旁边的弹出菜单，结合我在前两周收集的一些其他代码 sn-ps。我在下面发布我的最终代码。

【解决方案2】：

按照@Pork Chop 的出色指针和我之前的一些代码，我完成了以下代码（注意最后我点击了小部件标签旁边的图标/图像，而不是在小部件；这纯粹是为了避免混淆用户，并且因为右键单击（事件为contextmenu）已经打开了一个特定于浏览器的上下文菜单。代码会记住用户输入的数字并在哪里给出反馈总数超过或低于 100%（在我的情况下是相关的）。它也只接受条目，如果它们加起来正好 100%，否则上下文菜单不会消失。

我知道这个答案超出了我最初的问题，但我希望它对尝试做相同或类似的人有所帮助。

library(shiny)
library(shinyjs)

initialValues <- c(25, 25, 25, 25)

# 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(
      p(id = "coords", "Click me to see the mouse coordinates"), ## Example of the mouse click feedback

      div(style='display: inline-block;',
          "Click here for info",
          img(id = "image", src='https://www.zorro.com/wp-content/uploads/cc_resize/005-1200x542.jpg',height='30px',style='display: inline-block;', click = "image_click")
      ),
      uiOutput("plotClickInfo"),
      numericInput("bins",NULL,min = 1,max = 50,value = 30)

    ),

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

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

  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("coords", function(event) { alert(event) })

  ## Examples of other events we might use
  #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))

  ## The actual event we have used.
  onclick("image", function(event) {v$clickX <- event$pageX
                                    v$clickY <- event$pageY
                                    ## Store the initial values of the controls.
                                    if (!is.null(input$perc1)) {
                                      initialValues[1] <- input$perc1
                                    }
                                    else {
                                      v$perc1Value <- initialValues[1]
                                    }

                                    if (!is.null(input$perc2)) {
                                      initialValues[2] <- input$perc2
                                    }
                                    else {
                                      v$perc2Value <- initialValues[2]
                                    }

                                    if (!is.null(input$perc3)) {
                                      initialValues[3] <- input$perc3
                                    }
                                    else {
                                      v$perc3Value <- initialValues[3]
                                    }

                                    if (!is.null(input$perc4)) {
                                      initialValues[4] <- input$perc4
                                    }
                                    else {
                                      v$perc4Value <- initialValues[4]
                                    } 
                                    })

  output$plotClickInfo <- renderUI({

    if (!is.null(v$clickX)){
      style <- paste0("position:absolute; z-index:100; background-color: rgba(100, 245, 245, 0.85); max-width: 250px; width: 250px;",
                                          "left:", v$clickX + 2, "px; top:", v$clickY - 50, "px;")

                          # actual tooltip created as wellPanel
                          wellPanel(
                            style = style,
                            p(HTML(paste0("<b> KPI: </b>", "bla", "<br/>",
                                          "<b> Information: </b>", "aText"))),
                            numericInput("perc1", "Percentage1", v$perc1Value, 0, 100, width="100%"),
                            numericInput("perc2", "Percentage2", v$perc2Value, 0, 100, width="100%"),
                            numericInput("perc3", "Percentage3", v$perc3Value, 0, 100, width="100%"),
                            numericInput("perc4", "Percentage4", v$perc4Value, 0, 100, width="100%"),
                            conditionalPanel(style = "color: red;", condition = "(input.perc1 + input.perc2 + input.perc3 +
                                                                                   input.perc4 > 100)",
                                             "Total of percentages cannot exceed 100%"),
                            conditionalPanel(style = "color: red;", condition = "(input.perc1 + input.perc2 + input.perc3 +
                                                                                   input.perc4 < 100)",
                                             "Total of percentages must add up to 100%"),
                            actionButton("myAction", "Go"), actionButton("myCancel", "Cancel")
                          )
    }
    else return(NULL)
  })

  observeEvent(input$myAction, {
    ## Only disappear this popup
    if (input$perc1 + input$perc2 + input$perc3 + input$perc4 == 100) {
      v$perc1Value <- input$perc1
      v$perc2Value <- input$perc2
      v$perc3Value <- input$perc3
      v$perc4Value <- input$perc4
      v$clickX = NULL
    }
  })

  observeEvent(input$myCancel, {
    ## Revert to original values.
    updateNumericInput(session, "perc1", initialValues[1])
    updateNumericInput(session, "perc2", initialValues[2])
    updateNumericInput(session, "perc3", initialValues[3])
    updateNumericInput(session, "perc4", initialValues[4])
    v$clickX = NULL
  })
}

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

【讨论】：