How do I add plus and minus arrows to sliderInput() in shiny? - r

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)

Related

Shiny: Provide context menu on right click in numericInput?

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)

R Shiny: how to make input value conditionally reactive (on another input)?

I want the app to load a single time with default values, but become reactive only when the user types the correct password. To keep things simple let's work from the Rstudio template (minutely edited):
ui.R:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
passwordInput("pw", "Password:"),
sliderInput("nbins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("histo")
)
)))
server.R:
PASSWORD <- "test"
library(shiny)
shinyServer(function(input, output) {
output$histo <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$nbins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
There are two reactive inputs pw and nbins. My question is: How could the code be extended to make nbins (behavior) switch between reactive and non-reactive depending on the input pw being equal to PASSWORD?
Building on Valter's answer, you can use shinyjs to enable/disable interactivity with the input widget.
ui.R
library(shiny)
library(shinyjs) # install shinyjs
shinyUI(fluidPage(
useShinyjs(), # activate
sidebarLayout(
sidebarPanel(
passwordInput("pw", "Password:"),
sliderInput("nbins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("histo")
)
)))
server.R
library(shiny)
library(shinyjs)
shinyServer(function(input, output) {
observe({
if(input$pw != "PASSWORD") shinyjs::hide("nbins") else shinyjs::show("nbins")
})
output$histo <- renderPlot({
x <- faithful[, 2]
# will 'reset' bins to original value if incorrect pw
if(input$pw != "PASSWORD") {
bins <- seq(min(x), max(x), length.out = 30 + 1)
} else {
bins <- seq(min(x), max(x), length.out = input$nbins + 1)
}
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
What about this solution:
PASSWORD <- "test"
library(shiny)
shinyServer(function(input, output) {
bins <- eventReactive(input$nbins, {
if (input$pw == PASSWORD) {
bins <- seq(min(faithful[, 2]), max(faithful[, 2]), length.out = input$nbins + 1)
} else {
bins <- seq(min(faithful[, 2]), max(faithful[, 2]), length.out = 30 + 1)
}
})
output$histo <- renderPlot({
x <- faithful[, 2]
hist(x, breaks = bins(), col = 'darkgray', border = 'white')
})
})

Counter that increments each second and updates a plot, in R Shiny

I'm trying to create a timed counter within a Shiny app. When it increments each second, it should refresh a plot with some new characteristic that depends on the counter. Here's an example based on the 'Old Faithful' app. It doesn't work, but it gets at the idea. I tried to have reactiveTimer() refresh the plot, and a counter recorded with reactiveValues().
server.R
library(shiny)
shinyServer(function(input, output) {
refreshPlot <- reactiveTimer(intervalMs = 1000)
vals <- reactiveValues(counter = 0)
output$distPlot <- renderPlot({
refreshPlot()
vals$counter <- isolate(vals$counter) + 1
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
n_bins <- input$bins + vals$counter
bins <- seq(min(x), max(x), length.out = n_bins)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
ui.R
library(shiny)
shinyUI(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)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
invalidateLater is what I'm looking for. Thanks, Dieter. Below is the server.R that works.
library(shiny)
shinyServer(function(input, output, session) {
vals <- reactiveValues(counter = 0)
output$distPlot <- renderPlot({
invalidateLater(millis = 1000, session)
vals$counter <- isolate(vals$counter) + 1
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
n_bins <- input$bins + vals$counter
bins <- seq(min(x), max(x), length.out = n_bins)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})

Few panels within the sidebarPanel in shiny

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!

Shiny: Passing on text with a space to chart does not work, but it works without a space

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)

Resources