I have a question about shiny app. When there is no value select in numeric input and selectizeInput, my shiny app will show an error because of the empty data frame. I would like to hide the error message if user haven't select their input yet. I know if return will help but it seems not working in this app.
server.r:
library(shiny)
# Define server logic required to draw a histogram
shinyServer(function(input, output) {
result<-reactive({
if(is.null(input$wt)||is.null(input$hdcount)||is.null(input$season)||is.null(inp ut$gender) )return(NULL)
mod1<-lm(deathLog ~ InHdCnt+ log(InHdCnt) + season+ SexCode+ AvgArrivWt, data=mydata)
newdata = data.frame(AvgArrivWt=input$wt,InHdCnt=input$hdcount,SexCode=input$gender,season=input$season)
data<-predict(mod1, newdata, interval="predict",level=(input$slider1)*0.01 )
data
})
output$distPlot <- renderPrint({
result()
})
})
ui.r:
library(shiny)
# Define UI for application that draws a histogram
shinyUI(fluidPage(
# Application title
titlePanel("Death Loss Estimator with On Arrival Factors"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
numericInput("wt", label = h4("Average Arrival Weight input"),value="NULL"),
numericInput("hdcount", label = h4("Arrival Head Count input"),value="NULL"),
selectizeInput(
'season', h4('Arrival Season'), choices = c("spring", "summer","fall", "winter"),
options = list(
placeholder = 'Please select a season below',
onInitialize = I('function() { this.setValue(""); }')
)
),
selectizeInput(
'gender', h4('Arrival Sex'), choices = c("HOL", "FEM","MAL", "MIX"),
options = list(
placeholder = 'Please select a season below',
onInitialize = I('function() { this.setValue(""); }')
)
),
sliderInput("slider1", label = h4("Confidence Interval Level"), min = 50,
max = 100, value = 80)
),
# Show a plot of the generated distribution
mainPanel(
textOutput("distPlot")
)
)
))
Thanks!
I would recommend using validate and need. You can put this at the top of your reactive expression:
validate(
need(input$wt, "Please select a weight"),
need(input$hdcount, "Please select a head count")
)
Alternatively you can use req:
req(input$wt)
req(input$hdcount)
Related
Overview
Hello, I am trying to work with displaying different plots using checkboxes within tabsetPanels. I am working with a dynamic amount number of panels, so that is the reason for creating the UI contents within the server portion.
Ideal Output
For each tabPanel:
iris plot outputs if no checkboxes are selected
mtcars plot outputs if Box One is selected
islands plot outputs if Box Two is selected
sleep plot outputs if both Box One and Box Two are selected
What I have tried
-I have tried to use condtionalPanels to try to & capture the cases. I was under the impression that the value returns 'TRUE' if checked & 'FALSE' if unchecked, however I receive NULL for each of the boxed values, even if I set the default value to be checked.
-I believe my underlying issue is my lack of ability to trigger the dynamic checkboxes for each tabPanel
Disclaimer
This is a reproducible example, the default values of originally created tabPanels is set to 5. I did not accommodate proper code if the value were to change for the sake of simplicity.
Sample Code:
ui <- navbarPage(title="Dynamic tabsetPanels",id="navbar",
tabPanel("Home",
textInput(inputId = "numPanels",
label = "Enter # of Panels to produce",
value = 5)
),tabPanel("Analysis",
tabsetPanel(id = "tabs"))
)
server <- function(input, output) {
plotOne = renderPlot({plot(iris)})
plotTwo = renderPlot({plot(mtcars)})
plotThree = renderPlot({plot(islands)})
plotFour = renderPlot({plot(sleep)})
observe({
req(input$numPanels)
lapply(1:input$numPanels,function(i){
tabName = paste("Tab",i,sep=" ")
first = paste0("first",i)
second = paste0("second",i)
appendTab(inputId = "tabs",
tab = tabPanel(
tabName,
fluidPage(
sidebarLayout(
sidebarPanel(
#side-panel code
h2("Features"),
checkboxInput(inputId=first,label="Box One"),
checkboxInput(inputId=second,label="Box Two")
),mainPanel(
#output when nothing clicked
conditionalPanel(
condition = "!glue(input.{first} && !glue(input.{second})",
plotOutput(iris)
),
#output when box one is clicked
conditionalPanel(
condition = "glue(input.{first})",
plotOutput(mtcars)
),
#output when box two is clicked
conditionalPanel(
condition = "glue(input.{second})",
plotOutput(islands)
),
#output when box one and two are clicked
conditionalPanel(
condition = "glue(input.{first}) && glue(input.{second})",
plotOutput(sleep)
)
)
)
)
)
)
})
})
}
shinyApp(ui=ui, server=server)
Any suggestions would be greatly appreciated!
First issue with your code is the use of glue to create your conditions, i.e. you have to do e.g. condition = glue("input.{first}") instead of condition = "glue(input.{first})" to evaluate the glue string. Second issue is that in the plotOutputs you have to use the names of the outputs, e.g. plotOutput("plotOne") instead of plotOutput(iris). Finally, even after fixing these issues your app will not work as desired as you can't use outputs with the same id in several places or tabs, i.e. you get a duplicated id error. To fix that you also have to create a dynamic list of outputs so that the ids are unique.
library(shiny)
library(glue)
ui <- navbarPage(
title = "Dynamic tabsetPanels", id = "navbar",
tabPanel(
"Home",
textInput(
inputId = "numPanels",
label = "Enter # of Panels to produce",
value = 5
)
), tabPanel(
"Analysis",
tabsetPanel(id = "tabs")
)
)
server <- function(input, output) {
observe({
req(input$numPanels)
lapply(1:input$numPanels, function(i) {
output[[paste0("plotOne", i)]] <- renderPlot(plot(iris))
output[[paste0("plotTwo", i)]] <- renderPlot(plot(mtcars))
output[[paste0("plotThree", i)]] <- renderPlot(plot(islands))
output[[paste0("plotFour", i)]] <- renderPlot(plot(sleep))
})
})
observe({
req(input$numPanels)
lapply(1:input$numPanels, function(i) {
tabName <- paste("Tab", i, sep = " ")
first <- paste0("first", i)
second <- paste0("second", i)
appendTab(
inputId = "tabs",
tab = tabPanel(
tabName,
fluidPage(
sidebarLayout(
sidebarPanel(
# side-panel code
h2("Features"),
checkboxInput(inputId = first, label = "Box One"),
checkboxInput(inputId = second, label = "Box Two")
), mainPanel(
# output when nothing clicked
conditionalPanel(
condition = glue("!input.{first} && !input.{second}"),
plotOutput(paste0("plotOne", i))
),
# output when box one is clicked
conditionalPanel(
condition = glue("input.{first}"),
plotOutput(paste0("plotTwo", i))
),
# output when box two is clicked
conditionalPanel(
condition = glue("input.{second}"),
plotOutput(paste0("plotThree", i))
),
# output when box one and two are clicked
conditionalPanel(
condition = glue("input.{first} && input.{second}"),
plotOutput(paste0("plotFour", i))
)
)
)
)
)
)
})
})
}
shinyApp(ui = ui, server = server)
I'm a beginner in shiny app. so first I tried to build an app to calculate distance covered using time taken and speed. I got error as "argument of length zero". Then I entered req(input$num_time,input$select_time,input$slider_speed)this command after that error message is not displaying and also not getting output also. I'm not able to find where I gone wrong. Please help me in getting the output. I have shown the code I used below:
library(shiny)
#library(car)
ui <- fluidPage(
titlePanel("terrain model"),
sidebarLayout(
sidebarPanel(
helpText("To create a suitable model"),
br(),
numericInput("num_time",
label = h6("Enter time"),
value = 1),
selectInput("select_time",
label = h6(""),
choices = list("Hours"= 1,"Minutes" = 2),
selected = "1"),
sliderInput("Speed",
label = "Speed:",
min = 2, max = 4.5, value = 2),
br(),
actionButton("action",label="Refresh & Calculate")
),
mainPanel(
textOutput("text_distance")
)
)
)
server <- function(input, output) {
values <- reactiveValues()
#calculate distance travelled
observe({input$action_Calc
values$int <- isolate({ input$num_time * recode(input$select_time,"1='60';2='1'")*input$slider_speed
})
})
#Display values entered
output$text_distance <- renderText({
req(input$num_time,input$select_time,input$slider_speed)
if(input$action_Calc==0)""
else
paste("Distance:", round(values$int,0))
})
}
shinyApp(ui, server)
I don't find any use of "Refresh & Calculate" button since the calculation is performed as soon as any of the input changes.
You can try this code :
ui <- fluidPage(
titlePanel("terrain model"),
sidebarLayout(
sidebarPanel(
helpText("To create a suitable model"),
br(),
numericInput("num_time",
label = h6("Enter time"),
value = 1),
selectInput("select_time",
label = h6(""),
choices = list("Hours"= 1,"Minutes" = 2),
selected = "1"),
sliderInput("Speed",
label = "Speed:",
min = 2, max = 4.5, value = 2),
br(),
actionButton("action",label="Refresh & Calculate")
),
mainPanel(
textOutput("text_distance")
)
)
)
server <- function(input, output) {
#Display values entered
output$text_distance <- renderText({
val <- input$num_time/dplyr::recode(input$select_time,"1"=1,"2"=60)*input$Speed * 1000
paste("Distance:", round(val,0), 'meters')
})
}
shinyApp(ui, server)
I'm a bit of an RShiny and R novice. I'm trying to program an RShiny application. It would initially graphs a scatterplot matrix using the first three variables of the dataset by default. The user could then choose their own variable selections from a complete list of variables. Once variables are chosen, the user would click and action button and the graph would be recomputed using the newly selected variables.
I'm using selectinput rather than checkboxinput to accommodate datasets with many variables. I'm using the iris dataset. The code below produces the initial graph and allows the user to select the variables. I just can't figure out how to make it recompute the matrix plot. How do I do this? Thanks!
library(shiny)
runApp(list(
ui = fluidPage(
cols = colnames(iris),
headerPanel('Grow Clusters'),
tabsetPanel(
tabPanel("Plot",
sidebarPanel(
# uiOutput("varselect"),
selectInput("choose_vars", "Select variables to plot",
choices=colnames(iris), selected=iris[1:3], multiple=T),
actionButton("submitButton", "Produce Matrix Plot!")
),
mainPanel(
plotOutput('pairsplot')
)
),
tabPanel("Summary")
,
tabPanel("Table")
)
),
server = function(input, output) {
selectedData <- reactive({
cols = colnames(iris)
selectInput("choose_vars", "Select variables to plot",
choices=cols, selected=cols[1:3], multiple=T)
})
output$pairsplot <- renderPlot({
pairs(iris[1:3], pch = 21)
})
output$varselect <- renderUI({
iris[input$choose_vars]
plotOutput("pairsplot")
})
}
)
)
I think what you are looking for is quo function as in the Chris Beely blog: https://chrisbeeley.net/?p=1116
If you want users to pass arguments and then turn that character vector into objects r can read you need to use quo(input$choose_vars) and then in the plot you need to add !! before that passing variable. Notice you need to load dplyr.
library(shiny)
library(dplyr)
runApp(list(
ui = fluidPage(
cols = colnames(iris),
headerPanel('Grow Clusters'),
tabsetPanel(
tabPanel("Plot",
sidebarPanel(
# uiOutput("varselect"),
selectInput("choose_vars", "Select variables to plot",
choices=colnames(iris), selected=iris[1:3], multiple=T),
actionButton("submitButton", "Produce Matrix Plot!")
),
mainPanel(
plotOutput('pairsplot')
)
),
tabPanel("Summary")
,
tabPanel("Table")
)
),
server = function(input, output) {
selectedData <- reactive({
cols <- colnames(iris)
selectInput("choose_vars", "Select variables to plot",
choices=cols, selected=cols[1:3], multiple=T)
})
output$pairsplot <- renderPlot({
if(is.null(input$choose_vars) || length(input$choose_vars)<2){
pairs(iris[1:3], pch = 21)
} else {
var <- quo(input$choose_vars)
pairs(iris %>% select(!!var), pch = 21)
}
})
output$varselect <- renderUI({
iris[input$choose_vars]
plotOutput("pairsplot")
})
}
)
)
I'm a Shiny newbie and was trying to get something simple working, but unable to :(
Here is a part of my ui.R
sidebarLayout(
sidebarPanel(
radioButtons("market",
"Choose a Region to build the Sales file:",
c("North America & ANZ" = "NA", "Europe" = "EU"), inline = TRUE),
conditionalPanel(
condition = "input.market == 'NA'",
radioButtons("Locale",
"Choose a locale to see the sales Calendar:",
c("US and Canada" = "US_CA", "ANZ" = "ANZ"), inline = TRUE),
numericInput("sale_num", "Choose a Sale Number from the Table below",1,width = '100px' )
),
conditionalPanel(
condition = "input.market == 'EU'",
radioButtons("Locale",
"Choose a locale to see the sales Calendar:",
c("UK" = "UK", "FR and RoE" = "FR_ROE","DE,AT & CH" = "DACH"), inline = TRUE),
numericInput("sale_num", "Choose a Sale Number from the Table below",1,width = '100px' )),
dataTableOutput("sales"))
),
Here is my server.R
server <- shinyServer(function(input, output) {
output$sales <- renderDataTable({
saleTable(input$Locale)
},options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
})
When a change in the market radio button is triggered, the Locale radio does not update and hence the sales output table still has stale values and is not reflected by any change in Locale values.
I know I'm supposed to use something like UpdateRadiobuttons, but I'm not sure how. :(
saleTable is just a function in my Rscript that produces a data table.
Please help!
Thanks in advance!
Please post a minimal example, i.e. your function saleTable. Don't use the same input ID twice in your app, it's bad style and will not work in most cases. Here are two solutions: First one is bad style, second one better style.
1) Rename the second Locale to Locale2 and put this in your output$sales:
output$sales <- renderDataTable({
if(input$market == 'NA') data <- input$Locale
else if(input$market=="EU") data <- input$Locale2
saleTable(data)
}, options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
)
2) Create the second output as UIOutput and make it dependent on the first one:
ui <- shinyUI(
sidebarLayout(
sidebarPanel(
radioButtons("market",
"Choose a Region to build the Sales file:",
c("North America & ANZ" = "NA", "Europe" = "EU"), inline = TRUE),
uiOutput("Locale")),
mainPanel(dataTableOutput("sales"))))
server <- function(input, output, session) {
output$Locale <- renderUI({
if(input$market == "NA") myChoices <- c("US and Canada" = "US_CA", "ANZ" = "ANZ")
else myChoices <- c("UK" = "UK", "FR and RoE" = "FR_ROE","DE,AT & CH" = "DACH")
radioButtons("Locale","Choose a locale to see the sales Calendar:",
choices <- myChoices,
inline = TRUE)
})
output$sales <- renderDataTable({
saleTable(input$Locale)
},options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
}
shinyApp(ui = ui, server = server)
Based on the expressed interest in using updateRadioButtons, I put together a simple example with two radio buttons and a table output.
The first radio button input does not change. The second radio button input depends on the value of the first input. The table displayed is the mtcars data frame filtered by the values of the two radio button groups.
Using observeEvent ensures the value of the carb radio input updates each time the cyl radio input is changed. This will also trigger when the application is first launched and is why we do not see the default, dummy, choice "will be replaced" for the carb radio input.
Make sure to include session as one of the Shiny server function arguments. All of Shiny's update*Input functions require you pass a session object to them.
I hope this proves useful.
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(
width = 4,
radioButtons(
inputId = "cyl",
label = "Choose number of cylinders:",
choices = unique(mtcars$cyl),
selected = unique(mtcars$cyl)[1]
),
radioButtons(
inputId = "carb",
label = "Choose number of carburetors:",
choices = "will be replaced"
)
),
column(
width = 8,
tableOutput(
outputId = "mtcars"
)
)
)
),
server = function(input, output, session) {
observeEvent(input$cyl, {
newChoices <- sort(unique(mtcars[mtcars$cyl == input$cyl, ]$carb))
updateRadioButtons(
session = session,
inputId = "carb",
choices = newChoices,
selected = newChoices[1]
)
})
output$mtcars <- renderTable({
req(input$cyl, input$carb)
mtcars[mtcars$cyl == input$cyl & mtcars$carb == input$carb, ]
})
}
)
I'm building a new Shiny app and I although it works, the code is too extensive and it is not as reactive as I wanted. Right now I have at server.R
dayData <- reactive({...})
pday <- function(data){...}
output$distPlotday <- renderPlot(function() {print(pday(dayData)) })
and at ui.R
plotOutput("distPlotday")
for each variable in
checkboxGroupInput("checkGroup", "Dataset Features:",
choices = c("day","hour","source","service","relevancy","tollfree","distance","similarity"))
But I wish I could do something more fancy like this:
shinyServer(function(input, output, session) {
...
output$sliders <- renderUI({
lapply(input$checkGroup, function(i) {
fluidRow(
column(4,
selectInput(paste0('trans',i), i,
choices = c('linear','quadratic','sine')) ,
conditionalPanel(
condition = "input[[paste0('trans',i)]]== 'sine'",
withMathJax(),
h5("Put in your initial kicks for: $$a*\\sin(b*x+c)+d$$"),
textInput3(paste0('trans',i,'a'), h5('A:'),
value = 10),
textInput3(paste0('trans',i,'b'), h5('C:'),
value = 1),
textInput3(paste0('trans',i,'c'), h5('D:'),
value = 0.1),
helpText("Note: B has already been picked up")
),
plotOutput(paste0('distPlot',i))
))
})
})
...
}))
.
shinyUI(navbarPage("",
tabPanel("Data",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkGroup", label = h5("Dataset Features:"),
choices = c("day","hour","source","service","relevancy","tollfree","distance","similarity"), inline = F,
selected = c("day","hour","source","service","relevancy","tollfree","distance","similarity"))
),
mainPanel(
numericInput("obs", label = h5("Number of observations to view"), 15, min = 10, max = 20, step = 1),
tableOutput("view")
)
)
),
tabPanel("Variable transformation", uiOutput(outputId = "sliders"))
))
Using lapply and renderUI. But
plotOutput(paste0('distPlot',i))
is not ploting anything, and the
conditionalPanel(condition = "input[[paste0('trans',i)]]== 'sine'",...)
don't show up conditionally, instead it's always there.
Any suggestions? Thanks for the help!
I wasn't sure what you wanted to do with the plotOutput call, since as far as I can tell there wasn't any example code included that linked to it. However, I managed to put together a working example for dynamically showing/hiding the selection boxes and text fields for the sine parameters.
I found it easier to implement by moving the ui generation from the server into the ui. This gets around the problem of conditions being evaluated for input that doesn't exist yet, since on the ui side the functions are just writing html.
An additional benefit is that this way the input fields don't get re-rendered every time the checkbox input changes - this means that their values persist through toggling them on and off, and that enabling or disabling a single variable won't cause the others' values to reset.
The code:
library(shiny)
vars <- c("day","hour","source","service","relevancy",
"tollfree","distance","similarity")
ui <- shinyUI(navbarPage("",
tabPanel("Data",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkGroup", label = h5("Dataset Features:"),
choices = c("day","hour","source","service","relevancy",
"tollfree","distance","similarity"), inline = F,
selected = c("day", "hour","source","service","relevancy",
"tollfree","distance","similarity")
)
),
mainPanel(
numericInput("obs", label = h5("Number of observations to view"),
value = 15, min = 10, max = 20, step = 1),
tableOutput("view")
)
)
),
tabPanel("Variable transformation",
fluidRow(
column(4,
lapply(vars, function(i) {
div(
conditionalPanel(
condition =
# javascript expression to check that the box for
# variable i is checked in the input
paste0("input['checkGroup'].indexOf('", i,"') != -1"),
selectInput(paste0('trans',i), i,
choices = c('linear','quadratic','sine'))
),
conditionalPanel(
condition =
paste0("input['trans", i, "'] == 'sine' ",
" && input['checkGroup'].indexOf('", i,"') != -1"),
withMathJax(),
h5("Put in your initial kicks for: $$a*\\sin(b*x+c)+d$$"),
textInput(paste0('trans',i,'a'), h5('A:'), value = 10),
textInput(paste0('trans',i,'b'), h5('C:'), value = 1),
textInput(paste0('trans',i,'c'), h5('D:'), value = 0.1),
helpText("Note: B has already been picked up")
)
)
})
)
)
)
))
server <- shinyServer(function(input, output, session) {})
shinyApp(ui, server)
PS. For dynamically showing/hiding or enabling/disabling objects, the package shinyjs by Dean Attali (link) has some nice tools that allow you to call basic javascript by using only R syntax.