I have an app with two numericinput. Both presented values between 0 and 1. What I wanted to do is the following: As the sum of the two weights must equal 1, so when I select the first weight, for example, 0.2, the second will be 0.8. Got the idea?
Executable code below
library(shiny)
ui <- fluidPage(
numericInput("weight1", label = h4("Weight 1"),
min = 0, max = 1, value = 0.5),
numericInput("weight2", label = h4("Weight 2"),
min = 0, max = 1, value = 0.5),
helpText("The sum of weights should be equal to 1"),
hr(),
fluidRow(column(3, verbatimTextOutput("value1"))),
fluidRow(column(3, verbatimTextOutput("value2")))
)
server <- function(input, output,session) {
output$value1 <- renderPrint({ input$weight1 })
output$value2 <- renderPrint({ input$weight2 })
}
shinyApp(ui = ui, server = server)
You can do it by using observeEvent and updateNumericInput.
Here's what the code will look like:
server <- function(input, output,session) {
observeEvent(input$weight1, {
updateNumericInput(session, 'weight2',
value = 1 - input$weight1)
})
output$value1 <- renderPrint({ input$weight1 })
output$value2 <- renderPrint({ input$weight2 })
}
Note: You don't need updateNumericInput if you are dealing with only two numbers and every time you need the sum to be equal to 1.
Related
I'm looking at having two sliders that should update together, based on some function. For example, one slider is the square root of the other. I want to be able to change either slider and for the other one to update reactively.
The following does work:
library(shiny)
server = function(input, output) {
f = reactive(function(x) x^2)
finv =reactive(function(x) sqrt(x))
output$x <- renderUI({
slider_s.value <- input$s
default.slider_x <- if (is.null(slider_s.value)) 1 else f()(slider_s.value)
sliderInput("x", "Select x:",
min = 0, max=100,
value = default.slider_x, step = 0.01,
animate = animationOptions(interval = 600, loop = TRUE))
})
output$s <- renderUI({
slider_x.value <- input$x
default.slider_s <- if (is.null(slider_x.value)) finv()(1) else finv()(slider_x.value)
sliderInput("s", "Select s:",
min = 0, max=10,
value = default.slider_s, step = 0.01,
animate = animationOptions(interval = 600, loop = TRUE))
})
}
ui = fluidPage(
titlePanel("One Way Reactive Slider"),
fluidRow(
column(3,
wellPanel(
h4("Slider Inputs"),
uiOutput('s'),
uiOutput('x')
))
)
)
shinyApp(ui = ui, server = server)
However, this doesn't.
library(shiny)
server = function(input, output) {
g = reactive(function(x) x^2 - input$slider)
ginv =reactive(function(x) sqrt(x+ input$slider))
output$slider <- renderUI({
sliderInput("slider", "Slider input:",
min = 1, max = 100, value = 2)
})
output$x <- renderUI({
slider_s.value <- input$s
default.slider_x <- if (is.null(slider_s.value)) 1 else g()(slider_s.value)
sliderInput("x", "Select x:",
min = 0, max=100,
value = default.slider_x, step = 0.01,
animate = animationOptions(interval = 600, loop = TRUE))
})
output$s <- renderUI({
slider_x.value <- input$x
default.slider_s <- if (is.null(slider_x.value)) ginv()(1) else ginv()(slider_x.value)
sliderInput("s", "Select s:",
min = 0, max=10,
value = default.slider_s, step = 0.01,
animate = animationOptions(interval = 600, loop = TRUE))
})
}
ui = fluidPage(
titlePanel("One Way Reactive Slider"),
fluidRow(
column(3,
wellPanel(
h4("Slider Inputs"),
uiOutput('slider'),
uiOutput('s'),
uiOutput('x')
))
)
)
shinyApp(ui = ui, server = server)
It messes up when the "Slider Input" is changed. Is there some way that I can get round this? I've seen other posts on here about constraining sliders but none seem to rely on other inputs like this.
Note that I want x = g(s) and s = ginv(x) which should be okay since g and ginv are inverses of each other!
Some changes are required in output$x <- RenderUI code block to fix the slider values flickering issue.
output$x <- renderUI({
slider_slider.value <- input$slider
default.slider_x <- if (is.null(slider_slider.value)) 1 else g()(slider_slider.value)
sliderInput("x", "Select x:",
min = 0, max=100,
value = default.slider_x, step = 0.01,
animate = animationOptions(interval = 600, loop = TRUE))
})
I try to print in log an input which has been updated by a user in an app. Something very close can be done with observeEvent.
observeEvent(c(input$integer, input$decimal, input$range), {
flog.info(glue::glue('The user updated a value!'))
})
But I want to see in log the name of updated object without its containing values. How is it possible to do?
if (interactive()) {
library(shiny)
library(futile.logger)
library(glue)
ui <- fluidPage(
titlePanel("Sliders"),
sidebarLayout(
sidebarPanel(
sliderInput("integer", "Integer:",
min = 0, max = 1000,
value = 500),
sliderInput("decimal", "Decimal:",
min = 0, max = 1,
value = 0.5, step = 0.1),
sliderInput("range", "Range:",
min = 1, max = 1000,
value = c(200,500))
),
mainPanel(
tableOutput("values")
)
)
)
# Define server logic for slider examples ----
server <- function(input, output) {
observeEvent(c(input$integer, input$decimal, input$range), {
flog.info(glue::glue('The user updated a value!'))
})
# Reactive expression to create data frame of all input values ----
sliderValues <- reactive({
data.frame(
Name = c("Integer",
"Decimal",
"Range"),
Value = as.character(c(input$integer,
input$decimal,
paste(input$range, collapse = " "))),
stringsAsFactors = FALSE)
})
# Show the values in an HTML table ----
output$values <- renderTable({
sliderValues()
})
}
# Create Shiny app ----
shinyApp(ui, server)
}
A solution with the help of the shiny:inputchanged event:
library(shiny)
js <- "
$(document).on('shiny:inputchanged', function(e) {
if(e.name != 'updated' && e.name != '.clientdata_output_values_hidden'){
Shiny.setInputValue('updated', e.name, {priority: 'event'});
}
});"
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
titlePanel("Sliders"),
sidebarLayout(
sidebarPanel(
sliderInput("integer", "Integer:",
min = 0, max = 1000, value = 500),
sliderInput("decimal", "Decimal:",
min = 0, max = 1, value = 0.5, step = 0.1),
sliderInput("range", "Range:",
min = 1, max = 1000, value = c(200,500))
),
mainPanel(
tableOutput("values")
)
)
)
server <- function(input, output) {
observeEvent(input$updated, {
# do something with the name of the updated input,
# e.g flog.info(glue::glue(input$updated))
print(input$updated)
})
sliderValues <- reactive({
data.frame(
Name = c("Integer",
"Decimal",
"Range"),
Value = as.character(c(input$integer,
input$decimal,
paste(input$range, collapse = " "))),
stringsAsFactors = FALSE)
})
output$values <- renderTable({
sliderValues()
})
}
shinyApp(ui, server)
Following is the toned down version of my original problem. Here I am
trying to run an 'observeEvent' function into another 'observeEvent'
function. The code should perform the following steps sequentially:
On click of 'Print' button, Print the input number
On click of 'Add' button, Add +5 with the printed number
The code is working for first time only. From second time it is
showing the added number along with the printed without any click on
'Add' button.
Please help.
library(shiny)
ui <- fluidPage(
fluidRow(
sliderInput("n", min = 0, max = 100, value = 50, label = "Choose a number"),
actionButton("Print","Print the number"),
verbatimTextOutput("num1"),
actionButton("Add","Add +5 to the printed number"),
verbatimTextOutput("num2")
)
)
server <- function(input, output){
all <- reactiveValues(
n = 50,
a = 55
)
observeEvent(input$Print,{
all$n <- input$n
output$num1 <- renderPrint(all$n)
observeEvent(input$Add,{
all$d <- input$n + 5
output$num2 <- renderPrint(all$d)
})
})
}
shinyApp(ui = ui, server = server)
If you separate them, you can make the second observeEvent to get triggered from whatever happens inside the first one.
library(shiny)
ui <- fluidPage(
fluidRow(
sliderInput("n", min = 0, max = 100, value = 50, label = "Choose a number"),
actionButton("Print","Print the number"),
verbatimTextOutput("num1"),
actionButton("Add","Add +5 to the printed number"),
verbatimTextOutput("num2")
)
)
server <- function(input, output){
all <- reactiveValues(
n = 50,
a = 55
)
observeEvent(input$Print, {
all$n <- input$n
output$num1 <- renderPrint(all$n)
})
observeEvent(all$n, {
all$d <- input$n + 5
output$num2 <- renderPrint(all$d)
})
}
shinyApp(ui = ui, server = server)
I am working on a Shiny application in which there are two slider inputs. These inputted values subset a data frame differently, and the subset of that data frame is then plotted into a scatterplot.
I am trying to prevent the scatterplot from being replotted unless the user clicks a "Go!" button. To try to achieve this, I am using the isolate() function on the slider input values, so that the data frame and plot are only updated when the "Go!" button is changed.
This seems to be working okay, but I am also trying to allow the user to use the selection tool in Plotly and see the data frame rows that correspond to that selection. However, when I attempt to do so, I receive an error ("Error: object 'datInput' not found"). This line is commented in the example below:
library(shiny)
library(plotly)
ui <- shinyUI(pageWithSidebar(
headerPanel("Click the button"),
sidebarPanel(
sliderInput("val1", "Value 1:", min = 0, max = 1, value=0.5, step=0.1),
sliderInput("val2", "Value 2:", min = 0, max = 1, value=0.5, step=0.1),
actionButton("goButton", "Go!")
),
mainPanel(
plotlyOutput("plot1"),
verbatimTextOutput("click")
)
))
server <- shinyServer(function(input, output) {
set.seed(1)
dat <- data.frame(Case = paste0("case",1:15), val1=runif(15,0,1), val2=runif(15,0,1))
dat$Case <- as.character(dat$Case)
xMax = max(dat$val1)
xMin = min(dat$val1)
yMax = max(dat$val2)
yMin = min(dat$val2)
maxTemp = max(abs(xMax), abs(xMin))
observeEvent(input$goButton,
output$plot1 <- renderPlotly({
# Use isolate() to avoid dependency on input$val1 and input$val2
datInput <- isolate(subset(dat, val1 > input$val1 & val2 > input$val2))
p <- qplot(datInput$val1, datInput$val2) +xlim(0, ceiling(maxTemp)) +ylim(0,1)
ggplotly(p)
})
)
d <- reactive(event_data("plotly_selected"))
output$click <- renderPrint({
if (is.null(d())){
"Click on a state to view event data"
}
else{
#str(d()$pointNumber) #Seems to be working
datInput[d()$pointNumber,] #Error: object 'datInput' not found
}
})
})
shinyApp(ui, server)
Any ideas for a workaround for this issue would be appreciated!
EDIT:
Here is the solution as per #mlegge. I simply added the output after the user selects certain points:
library(shiny)
library(plotly)
ui <- shinyUI(pageWithSidebar(
headerPanel("Click the button"),
sidebarPanel(
sliderInput("val1", "Value 1:", min = 0, max = 1, value=0.5, step=0.1),
sliderInput("val2", "Value 2:", min = 0, max = 1, value=0.5, step=0.1),
actionButton("goButton", "Go!")
),
mainPanel(
plotlyOutput("plot1"),
verbatimTextOutput("click")
)
))
set.seed(1)
dat <- data.frame(Case = paste0("case",1:15), val1=runif(15,0,1), val2=runif(15,0,1))
dat$Case <- as.character(dat$Case)
xMax = max(dat$val1)
xMin = min(dat$val1)
yMax = max(dat$val2)
yMin = min(dat$val2)
maxTemp = max(abs(xMax), abs(xMin))
server <- shinyServer(function(input, output) {
# datInput only validated once the go button is clicked
datInput <- eventReactive(input$goButton, {
subset(dat, val1 > input$val1 & val2 > input$val2)
})
output$plot1 <- renderPlotly({
# will wait to render until datInput is validated
plot_dat <- datInput()
p <- qplot(plot_dat$val1, plot_dat$val2) + xlim(0, ceiling(maxTemp)) +ylim(0,1)
ggplotly(p)
})
d <- reactive(event_data("plotly_selected"))
output$click <- renderPrint({
if (is.null(d())){
"Click on a state to view event data"
}
else{
#str(d()$pointNumber)
datInput()[d()$pointNumber+1,] #Working now
}
})
})
shinyApp(ui, server)
You are not using isolate properly, a better solution is an eventReactive:
library(shiny)
library(plotly)
ui <- shinyUI(pageWithSidebar(
headerPanel("Click the button"),
sidebarPanel(
sliderInput("val1", "Value 1:", min = 0, max = 1, value=0.5, step=0.1),
sliderInput("val2", "Value 2:", min = 0, max = 1, value=0.5, step=0.1),
actionButton("goButton", "Go!")
),
mainPanel(
plotlyOutput("plot1")
)
))
set.seed(1)
dat <- data.frame(Case = paste0("case",1:15), val1=runif(15,0,1), val2=runif(15,0,1))
dat$Case <- as.character(dat$Case)
xMax = max(dat$val1)
xMin = min(dat$val1)
yMax = max(dat$val2)
yMin = min(dat$val2)
maxTemp = max(abs(xMax), abs(xMin))
server <- shinyServer(function(input, output) {
# datInput only validated once the go button is clicked
datInput <- eventReactive(input$goButton, {
subset(dat, val1 > input$val1 & val2 > input$val2)
})
output$plot1 <- renderPlotly({
# will wait to render until datInput is validated
plot_dat <- datInput()
p <- qplot(plot_dat$val1, plot_dat$val2) + xlim(0, ceiling(maxTemp)) +ylim(0,1)
ggplotly(p)
})
})
shinyApp(ui, server)
You'll notice that your data generation has been moved outside the server, this is because it only needs to be run once.
You also should never wrap an output object in an observer, instead control the input data with reactives.
I am trying to change the values from a sliderInput dynamically. The difficulty now is that I want to change from a sliderInput with one value, to a sliderInput with a range, which seems not to work.
The first actionbutton in the code below works, while the second does not what it is intended to do.
Is the only possibility to switch to an uiOutput element?
Code
library(shiny)
app <- shinyApp(
ui = bootstrapPage(
sliderInput("sld1", min = 0, max = 10, label = "y1", value = 5),
actionButton("acb1", "Change Value"),
actionButton("acb2", "Change Value to Range")
),
server = function(input, output, session) {
observeEvent(input$acb1, {
updateSliderInput(session, "sld1", value = 2)
})
observeEvent(input$acb2, {
updateSliderInput(session, "sld1", value = c(2,7))
})
})
runApp(app)
You can maybe add the slider dynamically using renderUI
#rm(list = ls())
library(shiny)
app <- shinyApp(
ui = bootstrapPage(
uiOutput("myList"),
actionButton("acb1", "Change Value"),
actionButton("acb2", "Change Value to Range")
),
server = function(input, output, session) {
slidertype <- reactiveValues()
slidertype$type <- "default"
observeEvent(input$acb1,{slidertype$type <- "normal"})
observeEvent(input$acb2, {slidertype$type <- "range"})
output$myList <- renderUI({
if(slidertype$type == "normal"){
sliderInput("sld1", min = 0, max = 10, label = "y1", value = 2)
}
else if(slidertype$type == "range"){
sliderInput("sld1", min = 0, max = 10, label = "y1", value = c(2,7))
}
else{
sliderInput("sld1", min = 0, max = 10, label = "y1", value = 5)
}
})
})
runApp(app)