I am working on an app that is supposed to take in numerical inputs, and then produce some visualizations and optimization results from said inputs. Problem is that there are conditions that should be met for the inputs, and if the conditions are violated I want a message to pop-up for the user instead of the results that are nonsensical.
For each numerical input there is a minimum value and maximum value. In this case, take the input 'X' in which I need X to be greater than 'X MIN' and less than 'X MAX'. I'm thinking of having the algorithm review the inputs either immediately or once the action button is clicked and if the conditions are violated then the outputs are hidden and a message pops up and states something like 'please ensure X is greater than the minimum value and less than the maximum value'. This would apply for any of the inputs that are violated. And then run successfully and show the outputs once conditions are validated correctly.
I have given it a couple different attempts and 'feel' that observeEvent is the way to go but my logic is not exactly correct. The shinyjs::hide commands seem to only work the first time that the action button is clicked and not the second, third, etc... when the button is clicked and the conditions are not evaluated. Surprisingly, the 'warning' messages seem to change immediately as I change the input themselves and not only when I press the actionButton, so clearly there is a disconnect with scoping here and what I think I'm coding vs. what is going on.
Aside from those observations I am realizing now that this code would not be able to display both xwarning and ywarning at the same time if the input conditions were not met for input$x and input$y or any combination since that is also desirable, so any tips on that would also be greatly appreciated. From my example below I hope individuals will notice after the first run that the algorithm is not successfully hiding and showing visuals correctly. I will continue to work on this but any help is appreciated.
Also exploring validate as an option. This is also my first post so any comments on how I asked this question are also appreciated.
library(DT)
library(shiny)
library(shinyjs)
library(plyr)
library(lubridate)
library(data.table)
library(tidyr)
options(scipen=999)
gc()
ui <- dashboardPage(
dashboardHeader(), # Have to try this one, title is not popping up
dashboardSidebar(size = "wide",
sidebarMenu( # Removes spinner from input boxes
tags$head(
tags$style(HTML("hr {border-top: 1px solid #000000;}"))
),
hr(),
numericInput('x','X Spend:', value = 1000000, min = 2, max = 5000000),
numericInput('y', 'Y Spend:', value = 50000, min = 2, max = 5000000),
numericInput('z', 'Z Spend:', value = 1500000, min = 2, max = 5000000),
hr(),
numericInput('xlb', 'X MIN:', value = 0, min = 1, max = 5000000),
numericInput('ylb', 'Y MIN:', value = 0, min = 1, max = 5000000),
numericInput('zlb', 'Z MIN:', value = 0, min = 1, max = 5000000),
hr(),
numericInput('xub', 'X MAX:', value = 2500000, min = 1, max = 5000000),
numericInput('yub', 'Y MAX:', value = 1500000, min = 1, max = 5000000),
numericInput('zub', 'Z MAX:', value = 3000000, min = 1, max = 5000000),
hr(),
menuItem(tabName= "main","X-Y-Z", icon = icon('chart area')),
menuItem(tabName = "xtb", "X Breakdown", icon = icon("table")),
menuItem(tabName = "yvb", "Y Breakdown", icon = icon("table")),
menuItem(tabName = "zbb", "Z Breakdown", icon = icon("table")),
actionButton('Run', 'Run App')
)
),
dashboardBody(
# Suppresses warning messages
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"),
# Set up Tab regimen
tabItems(selected = 1,
# Main tab
tabItem(tabName = "main",
# Plan Plot
box(width = 8, title = "X-Y-Z Spend",
color = "green", ribbon = T, title_side = "top right",
column(width = 8,
plotOutput(outputId = 'plot1', height = '100%')
)
),
# Solver Plot
box(width = 8, title = "X-Y-Z Logarithmic Spend",
color = "green", ribbon = T, title_side = "top right",
column(width = 8,
plotOutput(outputId = 'plot2', height = '100%')
)
),
DT::dataTableOutput('results') ,
verbatimTextOutput('xwarning'),
verbatimTextOutput('ywarning'),
verbatimTextOutput('zwarning'),
),
# Results table 1
tabItem(tabName = "xtb",
DT::dataTableOutput('results2')
),
# Results table 2
tabItem(tabName = "yvb",
DT::dataTableOutput('results3')
),
# Results TV
tabItem(tabName = "zbb",
DT::dataTableOutput('results4')
)
)
)
)
####################################################################################################################################################
####################################################################################################################################################
server <- shinyServer(function(input, output, session) {
go <- eventReactive(input$Run, {
x.y.z.spend <- as.matrix(rbind(input$x,
input$y,
input$z))
x.y.z.log.spend <- as.matrix(rbind(log(input$x),
log(input$y),
log(input$z)))
letters <- as.matrix(rbind('X',
'Y',
'Z'))
x.log <- log(input$x)
y.log <- log(input$y)
z.log <- log(input$z)
values <- as.matrix(cbind(input$x, input$y, input$z, x.log, y.log, z.log))
table.results <- DT::datatable(values, options = list(paging = F, searching = F, ordering = F, dom = 't',
columnDefs = list(list(className = 'dt-left', targets = "_all"))), rownames = F)
table.x <- DT::datatable(cbind(input$x,log(input$x)), options = list(paging = F, searching = F, ordering = F, dom = 't',
columnDefs = list(list(className = 'dt-left', targets = "_all"))), rownames = F)
table.y <- DT::datatable(cbind(input$y,log(input$y)), options = list(paging = F, searching = F, ordering = F, dom = 't',
columnDefs = list(list(className = 'dt-left', targets = "_all"))), rownames = F)
table.z <- DT::datatable(cbind(input$z,log(input$z)), options = list(paging = F, searching = F, ordering = F, dom = 't',
columnDefs = list(list(className = 'dt-left', targets = "_all"))), rownames = F)
list(table = table.results,
table2 = table.x,
table3 = table.y,
table4 = table.z,
x.y.z.spend,
x.y.z.log.spend,
letters
)
})
observeEvent(input$Run,{
if (input$x > input$xub || input$x < input$xlb){
shinyjs::hide('results')
shinyjs::hide('results2')
shinyjs::hide('results3')
shinyjs::hide('results4')
shinyjs::hide('plot1')
shinyjs::hide('plot2')
shinyjs::hide('ywarning')
shinyjs::hide('zwarning')
shinyjs::show('xwarning')
output$xwarning <- renderText({paste('Please ensure that',input$x,'is less than',input$xub,'and greater than',input$xlb)})
}
else if (input$y > input$yub || input$y < input$ylb){
shinyjs::hide('results')
shinyjs::hide('results2')
shinyjs::hide('results3')
shinyjs::hide('results4')
shinyjs::hide('plot1')
shinyjs::hide('plot2')
shinyjs::hide('xwarning')
shinyjs::hide('zwarning')
shinyjs::show('ywarning')
output$ywarning <- renderText({paste('Please ensure that',input$y,'is less than',input$yub,'and greater than',input$ylb)})
}
else if (input$z > input$zub || input$z < input$zlb){
shinyjs::hide('results')
shinyjs::hide('results2')
shinyjs::hide('results3')
shinyjs::hide('results4')
shinyjs::hide('plot1')
shinyjs::hide('plot2')
shinyjs::hide('xwarning')
shinyjs::hide('ywarning')
shinyjs::show('zwarning')
output$zwarning <- renderText({paste('Please ensure that',input$z,'is less than',input$zub,'and greater than',input$zlb)})
}
else {
shinyjs::hide('xwarning')
shinyjs::hide('ywarning')
shinyjs::hide('zwarning')
shinyjs::show('results')
shinyjs::show('results2')
shinyjs::show('results3')
shinyjs::show('results4')
shinyjs::show('plot1')
shinyjs::show('plot2')
output$results = renderDataTable({go()$table})
output$results2 = renderDataTable({go()$table2})
output$results3 = renderDataTable({go()$table3})
output$results4 = renderDataTable({go()$table4})
output$plot1 = renderPlot({pie(go()[[5]], labels = go()[[7]],col=c("red2","white","azure"))},
height = function(){
session$clientData$output_plot1_width
})
output$plot2 = renderPlot({pie(go()[[6]], labels = go()[[7]],col=c("red2","white","azure"))},
height = function(){
session$clientData$output_plot2_width
})
}
})
})
################################################################################################
shinyApp(ui, server)
validate is a very practical choice because it will handle warning messages in the outputs for you, avoiding the show-hide logic you're trying to implement:
MyValidation <- function(input) {
msg <- ""
if (input$x > input$xub || input$x < input$xlb) {
msg <- paste(
'Please ensure that',
input$x,
'is less than',
input$xub,
'and greater than',
input$xlb)
} else if (input$y > input$yub || input$y < input$ylb) {
msg <- paste(
'Please ensure that',
input$y,
'is less than',
input$yub,
'and greater than',
input$ylb)
} else if (input$z > input$zub || input$z < input$zlb) {
msg <- paste(
'Please ensure that',
input$z,
'is less than',
input$zub,
'and greater than',
input$zlb)
}
validate(need(msg == "", msg))
}
output$results = renderDataTable({MyValidation(input); go()$table})
output$results2 = renderDataTable({MyValidation(input);go()$table2})
output$results3 = renderDataTable({MyValidation(input);go()$table3})
output$results4 = renderDataTable({MyValidation(input);go()$table4})
output$plot1 = renderPlot({MyValidation(input)
pie(go()[[5]], labels = go()[[7]],col=c("red2","white","azure"))},
height = function(){
session$clientData$output_plot1_width
})
output$plot2 = renderPlot({MyValidation(input)
pie(go()[[6]], labels = go()[[7]],col=c("red2","white","azure"))},
height = function(){
session$clientData$output_plot2_width
})
The most visible limitation is that you'll get the same error message for each wrong output, but as it's displayed in a user-friendly manner it shouldn't be too disturbing.
If you prefer to have only one message, you can make a render function per tab, grouping together many outputs, with the same validation function as starting point.