Constraining a shiny app input based on another input - r

I have a basic shiny app that evaluates A + B:
library(shiny)
ui <- fluidPage(
numericInput(inputId = "A", label = "A", value = 5, step = 1),
sliderInput(inputId = "B", label = "B", min = 0, max = 10, value = 5),
textOutput(outputId = "value")
)
server <- function(input, output) {
output$value <- renderText(paste0("A + B = ", input$A + input$B))
}
shinyApp(ui = ui, server = server)
A is a numericInput value and B is a sliderInput value.
I want to constrain my app so that the maximum input value for B is always 2 * A. I, therefore, must change the hardcoded max = in sliderInput to something that can be dynamic. How can I accomplish this?
Thanks

You can call updateSliderInput to change the maximum value for B from within an observe which will be triggered whenever A changes:
library(shiny)
ui <- fluidPage(
numericInput(inputId = "A", label = "A", value = 5, step = 1),
sliderInput(inputId = "B", label = "B", min = 0, max = 10, value = 5),
textOutput(outputId = "value")
)
# Notice the session argument to be passed to updateSliderInput
server <- function(input, output, session) {
output$value <- renderText(paste0("A + B = ", input$A + input$B))
observe(updateSliderInput(session, "B", max = input$A*2))
}
shinyApp(ui = ui, server = server)

You are looking for renderUI()
library(shiny)
ui <- fluidPage(
numericInput(inputId = "A", label = "A", value = 5, step = 1),
uiOutput("slider"),
textOutput(outputId = "value")
)
server <- function(input, output) {
output$value <- renderText(paste0("A + B = ", input$A + input$B))
output$slider <- renderUI({
sliderInput(inputId = "B", label = "B", min = 0, max = 2*input$A, value = 5)
})
}
shinyApp(ui = ui, server = server)

Related

Shiny feedbackDanger doesnt work inside eventReactive where function is called

I am begginer in shiny an I am stucked adding feedback in my app.
I have tried a few things like write this code inside the eventReactive function like use the function feedBackDanger.
Below, there is a simplified full code with the ui, the idea is that i need the user get some Error (but not the console Error) if he set 'zero' in kind variable when mean is 3,6 or 9.
Also the actionButton 'simulate' should be disable when this condition is selected.
ui <- shinyUI(fluidPage(
titlePanel(h1("Simulation", align = 'center')),
sidebarLayout(
sidebarPanel(
numericInput(inputId = "n", label = "Size of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "mean", label = "Mean of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "var", label = "Variance", min = 1,
step = 0.25, value = 1),
radioButtons("kind", "Sample kind", choices = c("two", "zero")),
actionButton("simulate", "Simulate"),
width = 200
),
mainPanel(
plotOutput("distPlot", width = 500, height = 500)
)
)
))
# Define server logic required to draw a histogram
server <- shinyServer(function(input, output, session) {
s_fin <-function(n,
mean,
var,
kind){
a <- rnorm(n, mean, var)
if(kind == 'two'){
a <- a + 2
}
if(kind == 'zero'& mean %in% c(3,6,9)){
print('ERROR: function error')
stop(call. = T)}
return(a)
}
simulation <- eventReactive(input$simulate,{
s_fin(n = input$n,
mean = input$mean,
var = input$var,
kind = input$kind)
})
output$distPlot <- renderPlot({
hist(simulation())
})
})
shinyApp(ui, server)
The next code works to me (a just add useShinyFeedback() in ui.R, and put the error function instead of print):
library(shinyFeedback)
ui <- shinyUI(fluidPage(
useShinyFeedback(),
titlePanel(h1("Simulation", align = 'center')),
sidebarLayout(
sidebarPanel(
numericInput(inputId = "n", label = "Size of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "mean", label = "Mean of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "var", label = "Variance", min = 1,
step = 0.25, value = 1),
radioButtons("kind", "Sample kind", choices = c("two", "zero")),
actionButton("simulate", "Simulate"),
width = 200
),
mainPanel(
plotOutput("distPlot", width = 500, height = 500)
)
)
))
# Define server logic required to draw a histogram
server <- shinyServer(function(input, output, session) {
s_fin <-function(n,
mean,
var,
kind){
a <- rnorm(n, mean, var)
if(kind == 'two'){
a <- a + 2
}
if(kind == 'zero'& mean %in% c(3,6,9)){
showFeedbackDanger(
inputId = "mean",
text = "Not use mean 3, 6 or 9"
)
shinyjs::disable("simulate")
}else{
hideFeedback("mean")
shinyjs::enable("simulate")
}
return(a)
}
simulation <- eventReactive(input$simulate,{
s_fin(n = input$n,
mean = input$mean,
var = input$var,
kind = input$kind)
})
output$distPlot <- renderPlot({
hist(simulation())
})
})
shinyApp(ui, server)

Is there a way to only allow dragging a sliderInput?

I would like to fix the range in a shiny sliderInput such that it may only be dragged left or right, keeping the same range always. In the example below, the range is always kept to 10 but any range of 10 may be selected, e.g. 71-81 etc. Is it possible?
library(shiny)
ui <- fluidPage(
sliderInput(
inputId = "foo",
label = "Select Range",
min = 0,
max = 100,
value = c(50, 60),
step = 1,
dragRange = T
))
shinyApp(ui = ui, server = function(input, output) {})
Perhaps you are looking for this
library(shiny)
ui <- fluidPage(
sliderInput(
inputId = "foo",
label = "Select Range",
min = 0,
max = 100,
value = c(50, 60),
step = 1,
dragRange = T
))
server = function(input, output,session) {
observeEvent(input$foo[1], {
if (input$foo[1]<=90) mnval <- input$foo[1]
else mnval = 90
mxval = input$foo[1] + 10
updateSliderInput(session, "foo", min =0,max=100, value = c(mnval,mxval))
})
}
shinyApp(ui = ui, server = server)

Hide UI element: Shiny app crashes when UI element is placed under taglist

I have a simple shiny app and trying to hide and show elements using shinyjs(). I have attached the screenshots that show the UI for the first and second page along with input IDs for each element. The radio button "First page" should display all elements of "firstUI" and the "Second page" should display all the elements of "secondUI".
"firstUI"
"secondUI"
selectizeInput("two vars")
sliderInput("num1")
Inline fluidRow (Output("temp_num") and selectInput("units_temp")
sliderInput("num2")
"temp_out" renders an interactive slider and numeric input. Changing one , changes the other.The units dropdown converts the units of the entered value. 0F, 0C, K and R are the 4 temperature units I have used here. and their conversions are written inside functions Here is a screeshot of the app:
The problem I have is with this code block.
fluidRow(
uiOutput("temp_out"),
column(3,
selectInput("units_temp", "Units", choices = c("K", "C", "F", "R"), selected = "K")
)
)
If the above code block is inside taglist() of output$firstUI in server.R, as in my example below, the app crashes and I get an error:
Error in switch: EXPR must be a length 1 vector
The reason I want it inside "firstUI" is becasue I want to hide the elements when "Second page" is clicked. If the same block of code is under ui.R separately,(which I have commented) the app runs, but as expected, it is not hidden when "Second page" is clicked.
I don't understand what the the error is. Any help is appreciated. Thanks! Here is my code
#Unit conversion to Kelvin from a temerature unit
to_Kelvin <- function(value, unit){ # to SI (Kelvin)
switch(unit,
"K" = value,
"C" = value + 273.15,
"F" = (value -32) * (5 / 9) + 273.15,
"R" = value * 5 / 9)
}
#Unit conversion from a temperature unit to Kelvin
from_Kelvin <- function(value, unit){# from SI (Kelvin)
switch(unit,
"K" = value,
"C" = value - 273.15,
"F" = (value - 273.15) * (9 / 5) + 32,
"R" = value * 9 / 5)
}
# INPUTS
#parameters
parms <- list("Temperature" = "temp")
#slider range
range <- list("temp" = c(100, 500))
# / INPUTS
library(shiny)
library(shinyjs)
ui <- shinyUI(fluidPage(
useShinyjs(),
# Application title
titlePanel(title = "Shinyjs() example"),
sidebarLayout(
sidebarPanel(
radioButtons('pageID', label = NULL,choices = c('First page'='first', 'Second page'='second'), selected = 'first' ,inline = T),
HTML(
'<style>.col-sm-3, .col-sm-4 {
padding-left: 2px;
padding-right: 2px;
}
</style>'),
uiOutput('firstUI'),
# fluidRow(
# uiOutput("temp_out"),
# column(3,
# selectInput("units_temp", "Units", choices = c("K", "C", "F", "R"), selected = "K")
# )
# ),
#
hidden(uiOutput('secondUI'))
),
mainPanel(
fluidRow(
column(12,
textOutput("text")
)
)
)
)
)
)
server <- function(input, output,session) {
vls <- reactiveValues(previous_units = NULL, cur_temp = NA)
render_slider <- reactive({
f1 <- function(input_id, input_idnum, name, min, max, cur_val = NA){
set_val <- (min + max) / 2
if (! is.na(cur_val) && ! is.null(cur_val)) {
print(paste('setting', cur_val))
set_val <- as.numeric(cur_val)
}
ans <- list(column(width = 6, sliderInput((input_id), name, min = min, max = max, value = set_val, step = 0.00001)),
column(width = 3, numericInput(paste0(input_idnum), "Value", min = min, max = max, step = 0.00001, value = set_val))
)
return(ans)
}
return(f1)
})
rs <- reactive({
list(
"temp" = from_Kelvin(range$temp, input$units_temp)
)
})
observeEvent(input[["temp"]],{
vls[["cur_temp"]] <- as.numeric(input[["temp"]])
})
observeEvent(input[["units_temp"]],{
vls[["cur_temp"]] <- from_Kelvin (to_Kelvin (input[["temp"]], vls$previous_units["temp"]), input[["units_temp"]])
vls$previous_units["temp"] = input[["units_temp"]]
}, ignoreNULL = T, ignoreInit = T)
observeEvent(input[["temp_num"]],{
vls[["cur_temp"]] <- as.numeric(input[["temp_num"]])
})
observe({
if(is.null(vls$previous_units["temp"]) || is.na(vls$previous_units["temp"])){
print('unitssss')
vls$previous_units["temp"] = input[["units_temp"]]
print(vls$previous_units["temp"])
}
})
output$temp_out <- renderUI({
render_slider()("temp", "temp_num", "Temperature", min(rs()$temp), max(rs()$temp), vls$cur_temp)
})
output$firstUI <- renderUI({
tagList(
selectizeInput("two_vars",
"Select two variables",
c("A", "B", "C", "D", "E","F"),
selected=c("A", "B"),
multiple=T,
options = list(maxItems = 2)
),
fluidRow(
uiOutput("temp_out"),
column(3,
selectInput("units_temp", "Units", choices = c("K", "C", "F", "R"), selected = "K")
)
)
)
})
output$secondUI<-renderUI({
div(
sliderInput(
"num1",
"Enter number 1 ",
1,8,1
),
sliderInput(
"num2",
"Enter number 2",
1,8,1
)
)
})
observeEvent(input$pageID,{
if(input$pageID == 'first'){
shinyjs::hide('secondUI')
shinyjs::show('firstUI')
} else {
shinyjs::show('secondUI')
shinyjs::hide('firstUI')
}
})
output$text <- renderText({
paste("Temperature is", vls$cur_temp, input$units_temp, sep=" ")
})
}
# create a shiny app
shinyApp(ui=ui,
server=server)
You have created a interdependency and that will not work. You have reactive objects rs and vls depending on units_temp, but that cannot be rendered/defined in the same renderUI as it requires the same reactive objects.
If you change your render_slider() call to the following it works:
render_slider()("temp", "temp_num", "Temperature", min(range$temp), max(range$temp), 300)
To keep your current render_slider() call, define the selectInput for units_temp in a separate renderUI and it will work.
Full working code is below. You can update it to make it work with the reactive object vls, and space between different items in ui - as you are also using HTML code.
# INPUTS
#parameters
parms <- list("Temperature" = "temp")
#slider range
range <- list("temp" = c(100, 500))
# / INPUTS
library(shiny)
library(shinyjs)
ui <- shinyUI(fluidPage(
useShinyjs(),
# Application title
titlePanel(title = "Shinyjs() example"),
sidebarLayout(
sidebarPanel(
radioButtons('pageID', label = NULL,choices = c('First page'='first', 'Second page'='second'), selected = 'first' ,inline = T),
HTML(
'<style>.col-sm-3, .col-sm-4 {
padding-left: 2px;
padding-right: 2px;
}
</style>'),
uiOutput('firstUI'),
# fluidRow(
# uiOutput("temp_out"),
# column(3,
# selectInput("units_temp", "Units", choices = c("K", "C", "F", "R"), selected = "K")
# )
# ),
#
hidden(uiOutput('secondUI'))
),
mainPanel(
fluidRow(
column(12,
textOutput("text")
)
)
)
)
)
)
server <- function(input, output,session) {
vls <- reactiveValues(previous_units = NULL, cur_temp = NA)
render_slider <- reactive({
f1 <- function(input_id, input_idnum, name, min, max, cur_val = NA){
set_val <- (min + max) / 2
if (! is.na(cur_val) && ! is.null(cur_val)) {
print(paste('setting', cur_val))
set_val <- as.numeric(cur_val)
}
ans <- list(column(width = 6, sliderInput((input_id), name, min = min, max = max, value = set_val, step = 0.00001)),
column(width = 3, numericInput(paste0(input_idnum), "Value", min = min, max = max, step = 0.00001, value = set_val))
)
return(ans)
}
return(f1)
})
rs <- reactive({
req(input$units_temp)
list(
"temp" = from_Kelvin(range$temp, input$units_temp)
)
})
# observeEvent(input[["temp"]],{
#
# vls[["cur_temp"]] <- as.numeric(input[["temp"]])
#
# })
#
# observeEvent(input[["units_temp"]],{
#
# vls[["cur_temp"]] <- from_Kelvin (to_Kelvin (input[["temp"]], vls$previous_units["temp"]), input[["units_temp"]])
#
# vls$previous_units["temp"] = input[["units_temp"]]
#
# }, ignoreNULL = T, ignoreInit = T)
#
# observeEvent(input[["temp_num"]],{
#
# vls[["cur_temp"]] <- as.numeric(input[["temp_num"]])
#
# })
#
# observe({
#
# if(is.null(vls$previous_units["temp"]) || is.na(vls$previous_units["temp"])){
# print('unitssss')
#
# vls$previous_units["temp"] = input[["units_temp"]]
# print(vls$previous_units["temp"])
# }
# })
#
#
output$temp_out <- renderUI({
render_slider()("temp", "temp_num", "Temperature", min(rs()$temp), max(rs()$temp), vls$cur_temp)
#render_slider()("temp", "temp_num", "Temperature", min(range$temp), max(range$temp), 300)
})
output$temp_out2 <- renderUI({
selectInput("units_temp", "Units", choices = c("K", "C", "F", "R"), selected = "K", width=50)
})
output$text <- renderText({
#paste("Temperature is", vls$cur_temp, input$units_temp, sep=" ")
paste("Temperature is", min(rs()$temp), "-", max(rs()$temp) , sep=" ")
})
output$firstUI <- renderUI({
#req(rs(),render_slider())
tagList(
selectizeInput("two_vars",
"Select two variables",
c("A", "B", "C", "D", "E","F"),
selected=c("A", "B"),
multiple=T,
options = list(maxItems = 2)
),
fluidRow(
column(10,uiOutput("temp_out")), column(2,uiOutput("temp_out2"))
#column(3, selectInput("units_temp", "Units", choices = c("K", "C", "F", "R"), selected = "K") )
)
)
})
output$secondUI<-renderUI({
div(
sliderInput(
"num1",
"Enter number 1 ",
1,8,1
),
sliderInput(
"num2",
"Enter number 2",
1,8,1
)
)
})
observeEvent(input$pageID,{
if(input$pageID == 'first'){
shinyjs::hide('secondUI')
shinyjs::show('firstUI')
} else {
shinyjs::show('secondUI')
shinyjs::hide('firstUI')
}
})
# output$text <- renderText({
#
# paste("Temperature is", vls$cur_temp, input$units_temp, sep=" ")
# })
}
# create a shiny app
shinyApp(ui=ui, server=server)

Make a shiny UI (e.g. sliderInput) object vary based on the users input

library(shiny)
ui <- fluidPage(
shiny::titlePanel("Hurricane Maps"),
sidebarLayout(
sidebarPanel(shiny::selectInput('names', 'Choosing something:', choices=c('A', 'B', 'C'),
shiny::sliderInput("duration", "Range of Storm:", min = should_vary,
max = should_vary, value = c( should_vary, should_vary)
))
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
The above is the code.
I need the "should_vary" to vary based on whether A, B, or C was selected.
You have to:
Use renderUI within shiny server part to programmatically create a UI object
This object should depend on the names ID (i.e. you have to make input$names reactive)
In the UI part you have to insert rendered object with uiOutput
Code:
library(shiny)
ui <- fluidPage(
selectInput("names", "Choosing something:", c("A", "B", "C"), "A"),
uiOutput("duration_rendered")
)
server <- function(input, output) {
input_names <- reactive({
switch(input$names, "A" = 1, "B" = 2, "C" = 3)
})
output$duration_rendered <- renderUI({
sliderInput(
"duration",
"Range of Storm:",
min = input_names(),
max = input_names() + 10,
value = c(input_names(), input_names() + 10)
)
})
}
shinyApp(ui, server)

Calculate in Shinyapps

I want to calculate some values and return the values to my shiny app:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(numericInput(inputId = "ME",
label = "Maternal effect:",
min = -1,
max = 1,
value = 0.5),
numericInput(inputId = "CE",
label = "Child effect:",
min = -1,
max = 1,
value = 0.5)
),
mainPanel(h3(textOutput("Power"))
)
)
)
server <- function(input, output) {
bzc <- sqrt(abs(input$CE)) * sign(input$CE)
bzm <- sqrt(abs(input$ME)) * sign(input$ME)
results <- bzc * bzm
output$Power <- renderPrint({results
})
}
shinyApp(ui = ui, server = server)
This doesnt apprear to work. Any tips on how to calculate in the shiny app?
The error-messages arise, because you have input-objects outside of the render-functions. If you want to calculate something, which you want to reuse in multiple plots, then use a reactive or observe-function.
For all other cases it is enough add the code for bzc, bzm and result inside the render-functions:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(numericInput(inputId = "ME",
label = "Maternal effect:",
min = -1,
max = 1,
value = 0.5),
numericInput(inputId = "CE",
label = "Child effect:",
min = -1,
max = 1,
value = 0.5)
),
mainPanel(h3(textOutput("Power"))
)
)
)
server <- function(input, output) {
output$Power <- renderPrint({
bzc <- sqrt(abs(input$CE)) * sign(input$CE)
bzm <- sqrt(abs(input$ME)) * sign(input$ME)
results <- bzc * bzm
results
})
}
shinyApp(ui = ui, server = server)

Resources