I have been asked to create something I'm not sure is possible in Shiny: a context menu that appears when a user right-clicks on a numeric input. I know how to show a context popup on a chart (see code below), but this doesn't help me answer the following:
Can an input widget catch a click / hover / right click event?
Can I generate a Shiny menu in this kind of popup window?
I'm happy to receive answers along the lines of 'not possible' or 'not possible unless you learn all of Javascript today'. If so I will think of another way to incorporate this kind of context-sensitive response in the interface.
Example code that produces a hovering window on click on a chart:
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)
You can use wonderful shinyjs package which has a lot of event listeners built. Have a look at his docs https://cran.r-project.org/web/packages/shinyjs/shinyjs.pdf. If you want to reconcile some jquery events look here http://api.jquery.com/category/events/mouse-events/
Here is an example of some of them you might find useful, I think the right click is the mousedown event, but you can check
#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))
Code:
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)
Following the excellent pointers by #Pork Chop and some previous code that I had, I have finished with the following code (note in the end I have gone with clicking on an icon / image next to the widget label rather than inside the widget; this purely to avoid confusing the user, and because the right click (for which the event is contextmenu) brings up a browser-specific context menu already. The code remembers the numbers that the user has entered and gives feedback where the totals go over or under 100% (relevant in my case). It also only accepts the entries if they add up to exactly 100%, otherwise the context menu will not disappear.
I know this answer goes beyond my initial question but I hope it may be helpful for someone trying to do the same or similar.
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)
Related
I can see how to use actionButton to delay an output, but I haven't seen an example relevant to what I am trying to do, which is delay the start of a defined function that is called within another output.
Simplified for the MRE, let's say I have an output to create the mean of a data set. I have three ways to calculate the mean. One of those ways takes a long time though (simulated here by Method 2). Here is the way it is structured now.
How can I get algo(x) to wait until the button is pressed, then start the calculation and return the value?
library(shiny)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
radioButtons(inputId = "calc_t",label = "Select Calculation",choices = c("Method 1"=1,"Method 2 (long)"=2,"Method 3"=3)),
actionButton(inputId = "go_algo",label = "Start Algo")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot"),
textOutput("analyze")
)
)
)
# 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',
xlab = 'Waiting time to next eruption (in mins)',
main = 'Histogram of waiting times')
})
output$analyze <- renderText({
calc_type<-input$calc_t
x <- faithful[, 2]
if(calc_type==1){
output<-paste("Mean 1 = ",mean(x))
} else if (calc_type==2){
output<-paste("Mean 2 = ",algo(x))
} else if(calc_type==3){
output<-paste("Mean 3 = ",sum(x)/length(x))
}
})
algo<-function(x){
mean_x<-mean(x)
#stuff that would take a long time
output<-mean_x+100
return(output)
}
}
# Run the application
shinyApp(ui = ui, server = server)
I would suggest using an observeEvent for the action button for the function that needs to wait for the button. For this observeEvent a req is required to limit the button to work only for this choice. Then you can use another observeEvent for the the other choices and again limit what is allowed to run without a button click with req.
Here's the updated server code:
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',
xlab = 'Waiting time to next eruption (in mins)',
main = 'Histogram of waiting times')
})
observeEvent(input$calc_t, {
req(input$calc_t!=2)
output$analyze <- renderText({
calc_type<-input$calc_t
x <- faithful[, 2]
if(calc_type==1){
output<-paste("Mean 1 = ",mean(x))
} else if(calc_type==3){
output<-paste("Mean 3 = ",sum(x)/length(x))
}
})
})
observeEvent(input$go_algo, {
req(input$calc_t==2)
output$analyze <- renderText({
isolate(calc_type<-input$calc_t)
x <- faithful[, 2]
output<-paste("Mean 2 = ",algo(x))
})
})
algo<-function(x){
mean_x<-mean(x)
#stuff that would take a long time
output<-mean_x+100
return(output)
}
}
I am using bsModal() window from the ShinyBS package in one of my Shiny Apps. Whenever the user opens the modal window for the second time, the contents of the window from the first opening remain on the screen until the new content loads. Which is not ideal. Is there a way to delete the contents of the bsModal() window once it is closed? I do not want the older content to appear in the window once it is reopened. Subsequently, maybe there is a way to clean up the bsModal() window before opening?
I wasn't able to find any solution for this
Here is some example (not my) code of an app that can be also accessed through:
library(shinyBS)
bsExample("Modals")
ui.R
library(shiny)
library(shinyBS)
fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
actionButton("tabBut", "View Table")
),
mainPanel(
plotOutput("distPlot"),
bsModal("modalExample", "Data Table", "tabBut", size = "large",
dataTableOutput("distTable"))
)
)
)
server.R
library(shiny)
library(shinyBS)
shinyServer(
function(input, output, session) {
output$distPlot <- renderPlot({
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$distTable <- renderDataTable({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
tab <- hist(x, breaks = bins, plot = FALSE)
tab$breaks <- sapply(seq(length(tab$breaks) - 1), function(i) {
paste0(signif(tab$breaks[i], 3), "-", signif(tab$breaks[i+1], 3))
})
tab <- as.data.frame(do.call(cbind, tab))
colnames(tab) <- c("Bins", "Counts", "Density")
return(tab[, 1:3])
}, options = list(pageLength=10))
}
)
I am developing a shiny app and want to improve the accuracy of the slider (the slider ranges from 0 to 1000 and it's very difficult to accurately adjust the slider with a step of 1). I can't find an answer to this anywhere.
This is the code for one of my sliders:
sliderInput("mean2", "", min=0, max=1000, value=500, step=1)
Try arranging your code like such:
library(shiny)
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
actionButton("minus", "Minus"),
actionButton("plus", "Plus"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("mean2",
"Number of bins:",
min = 0,
max = 1000,
value = 500,
step= 1)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output, session) {
v <- reactiveValues(data = 500)
observeEvent(input$minus, {
v$data <- input$mean2 - 1
updateSliderInput(session,"mean2", value = input$mean2 - 1)
})
observeEvent(input$plus, {
v$data <- input$mean2 + 1
updateSliderInput(session,"mean2", value = input$mean2 + 1)
})
observeEvent(input$mean2, {
v$data <- input$mean2
})
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = v$data + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
shinyApp(ui, server)
I am building my first app in shiny. The problem to solve is like this.
I've ui
shinyUI(fluidPage(
# Application title
titlePanel("My"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel("Variables",
sliderInput("bins",
"Number of circles:",
min = 1,
max = 50,
value = 30),
sliderInput("bins",
"Number of triangels:",
min = 1,
max = 50,
value = 1)
),
# Show a plot of the generated distribution
mainPanel(tabsetPanel(
tabPanel("Data", plotOutput("distPlot")),
tabPanel("Data1", textOutput("text1")),
tabPanel("Data2", plotOutput("distPlot1")))
)
)
))
and server
shinyServer(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$distPlot1 <- renderPlot({
x <- faithful[, 2]
plot(density(x))
})
output$text1 <- renderText({
"Hello mother"
})
})
The question concern ui part. I'd like to fave 2 panels in the sidebarPanel - triangles and circles, similar to that what is in the mainPanel i.e. Data, Data1, Data2.
Thanks for the comments!
My Shiny script gets input from a drop down list. Based on this, I set (on the server side) a specific string (in a reactive) that should be displayed in the chart (for example as x axis title). This works only if the string contains no spaces, but no string is shown in the chart if contains spaces.
How can I get it to accept any string?
Here's my code (I modified one of the example from the Shiny tutorial to keep it as simple as possible):
# server.r
# Here the string is set depending on what was chosen by the user
shinyServer(function(input, output, session) {
label1_new <- reactive({
if (input$variable1=="pp_pmw") {label1_new <- "PP pmw"}
if (input$variable1=="perc_pp*100") {label1_new <- "PP percent"}
if (input$variable1=="formality") {label1_new <- "Formality"}
})
label1_new2 <- renderText({label1_new()})
output$distPlot <- renderPlot({
x <- faithful[, 2] # Old Faithful Geyser data
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
# xlabel1_new2() contains the string from above
hist(x, breaks = bins, col = 'darkgray', border = 'white', xlab=label1_new2())
})
})
# ui.r
library(shiny)
shinyUI(fluidPage(
# Application title
titlePanel("Hello Shiny!"),
# Sidebar with a slider input for the number of bins
sidebarLayout(
sidebarPanel(
selectInput("variable1", "Circle size:",
list("PP pmw" = "pp_pmw",
"PP percent" = "perc_pp*100",
"Formality" = "formality")),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
))
renderText is for use with ui.r, not for creating strings to be used in server.r
# server.r
# Here the string is set depending on what was chosen by the user
shinyServer(function(input, output, session) {
label1_new <- reactive({
if (input$variable1=="pp_pmw") return("PP pmw")
if (input$variable1=="perc_pp*100") return("PP percent")
if (input$variable1=="formality") return("Formality")
})
output$distPlot <- renderPlot({
x <- as.numeric(unlist(faithful[, 2])) # Old Faithful Geyser data
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', xlab=label1_new())
})
})
(same ui.r)