3

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)
leo.szn
  • 33
  • 3

1 Answers1

1

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:

  1. create a validation function
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))
}
  1. put this function at the beginning of all the render functions:
  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.

Waldi
  • 39,242
  • 6
  • 30
  • 78
  • ohhhh this is really interesting! I feel like I am closer to my solution. When implementing this method were you able to get a message through `validate`? When I ran this the code would remove any present outputs but not display any message. Moreover, it appears as if the app runs regardless if the user clicks on 'Run App'. Anywho, look forward to any comments and will continue to tinker with this, thank you :). – leo.szn Jul 16 '20 at 21:44
  • I didn't make a test run in this specific case, but I use validate a lot , and this [article](https://shiny.rstudio.com/articles/validation.html) should give you a good overview. Are you sure you stopped the App in RStudio (not only closed the browser)? – Waldi Jul 16 '20 at 21:51
  • Oh I see. I was previously suppressing error messages and I realize that `validate` uses R's error messages to showcase the function message. Now they pop up. Though you are correct in indicating that the same error message is displayed regardless of input violation. I would need some more clear instructions so thinking different functions perhaps to display the different input violations. Now to also figure out why my app is running on its own before clicking _Run App_ as well. Thank you for the help and will be around for a bit before accepting your answer! @Waldi – leo.szn Jul 16 '20 at 22:54
  • accepted! As a follow up comment I would be interested in how you mentioned I can have _only one message_ w.r.t creating a render function per tab, grouping the output and having the validation f(x) as the beginning point. I would be interested in having one message opposed to multiple in one tab. Any pointers are appreciated :). @Waldi – leo.szn Jul 17 '20 at 00:50
  • you can use [renderUI](https://shiny.rstudio.com/reference/shiny/0.14/renderUI.html) to create a whole tab, fluidPage, ..., and put the Validation function in this renderer. The associated uiOutput will have only one error message. – Waldi Jul 17 '20 at 07:20