我被要求在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)
答案 0 :(得分：3)
您可以使用构建了大量事件侦听器的精美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)
答案 1 :(得分：1)
按照@Pork Chop的优秀指针和我之前的一些代码，我已经完成了以下代码（注意到最后我点击了小部件标签旁边的图标/图像，而不是在widget;这纯粹是为了避免混淆用户，并且因为右键单击（事件为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)