Home Validating Shiny web applications' inputs using shinyvalidate
Post
Cancel

Validating Shiny web applications' inputs using shinyvalidate

Posted Sep 20, 2022 Updated Oct 27, 2022
By Weal Mohammed
23 min read

Introduction:

Almost all Shiny-powered web-applications allow or require end-user inputs, and it could be the case that some of these inputs accept values within a specific range (only positive values, for example). Moreover, it can be the case that R will not warn users about the wrong inputs or that such warnings never make it to the user interface (UI).

Shiny, the R package, has several solutions for such scenarios; however, this post will focus on shinyvalidate, a package that works seamlessly with shiny.

So, in this post, we will:

Relevance, prerequisites and difficulty:

Relevance:

The inputs of decision-analytic models, commonly used in Health Technology Assessment (HTA), are mostly bounded. For example, while the normal distribution serves unbounded variables (accepts any value from -infinity to infinity), its dispersion parameter (the standard deviation) must be positive. Therefore, shiny apps serving such models must be capable of warning users against unacceptable values.

Difficulty:

Employing the code we demonstrate in this post is relatively easy.

Prerequisites:

First, we expect readers to have a basic understanding of:

  • R, and
  • shiny.

Finally, we host the complete code and files resulting from the steps we discuss below in the “validating-shiny-inputs-using-shinyvalidate” folder on the GitHub repository.

The shiny app we will use:

Since this post focuses on improving how a shiny app validates user inputs, we will try to keep this simple and re-use the Smith et al. (2022) shiny application (version 1 of the code). The code in the server.R script, which is also available in the “controlling-and-monitoring-access-to-plumber-powered-APIs” folder on my GitHub repository, is under the Code section below.

What should we expect from shinyvalidate:

The package shinyvalidate adds input validation capabilities to Shiny1. Users start by creating one or more input validators and attaching rules to them; functions supplied by the package then utilise these rules to validate associated inputs.

Before we explain the above statements using an example, the shinyvalidate process involves:

  1. creating one or more input validator objects,
  2. attaching rules to specific shiny inputs (using their inputIds),
  3. enabling the shinyvalidate package to display feedback on the UI, and
  4. optionally guard calculations until all validation rules are obeyed.

A simple example:

The following demo app (adapted from here) requires two user inputs, one of which is an email address. The code below shows:

  • creating an input validator,
  • attaching rules to the input validator, and
  • adding messages for when those rules are violated.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

if(interactive()) {
  library(shiny)
  library(shinyvalidate)
  library(lubridate)

  ui <- fluidPage(
    # Define user-inputs:
    textInput(inputId = "name", label = "Name"),
    textInput(inputId = "email", label = "Email"),
    dateInput(inputId = "dob", label = "Date of birth", value = NA),
    # Define outputs:
    textOutput("greeting")
  )

  server <- function(input, output, session) {
    # Defining a function:
    get_age <- function(value, today) {
      if(is.Date(value)) {
        dT.int <- lubridate::interval(value, today)
        dT.length <- lubridate::time_length(dT.int, unit = "year")
        if(floor(dT.length) < 18) {
          "You are too young to be allowed access to these secure details"
        }
      }
    }
    # Validating inputs:
    ## 1. Create an InputValidator object:
    iv <- InputValidator$new()

    ## 2. Add validation rules:
    iv$add_rule(inputId = "name", rule = sv_required())
    iv$add_rule(inputId = "email", rule = sv_optional())
    iv$add_rule(inputId = "email", rule = sv_email("Please add a valid email address!"))
    iv$add_rule(inputId = "dob", rule = sv_required())
    iv$add_rule(inputId = "dob", rule = get_age, today = Sys.Date())

    ## 3. Start displaying errors in the UI:
    iv$enable()

    output$greeting <- renderText({
    ## 4. Don't proceed if any input is invalid
    req(iv$is_valid())
    
    paste0("Nice to meet you, ", input$name, " <", input$email, ">!")
    })
  }

  # Launch the app:
  shinyApp(ui, server)
}

Let us dissect the code chunk above before running the code chunk above in R’s console.

The get_age function:

Above, we defined get_age() to check if users are 18 years or old. In this function, we:

  • estimated the length of time between user input and the current day,
  • transformed that value to years,
  • truncated the number of years to get the user’s age at their last birthday, and
  • provided feedback to the user if they were not at least 18 years old.

The input validator:

In the code chunk above, we used InputValidator$new() to create an instance of class InputValidator and save it under the name iv. We then used the object-specific class method or function add_rule to declare validation rules; notice how we used the dollar sign $ to access the add_rule function in the iv object. Finally, by invoking ‘ enable()’, we allow the iv input validator to push and display any error messages to the UI.

The name input:

This input is a text input, which means shiny expects any set of characters; however, we decided that this input was a requirement and attached a rule to iv (the input validator) using the sv_required helper function. Then, running the app (by pasting the code chunk above in an RStudio session-console), we can see the word “Required” under the “Name” input box as long as the name text field is empty.

The email input:

On the other hand, we decided that the email input field was optional (using sv_optional()), which means that the input validator iv will not bother itself or the user until the user enters one or more characters. Additionally, we used sv_email("Please add a valid email address!") so that once the user adds content to the text box, the input validator will ensure that the provided text adheres to the format username@domainname.extension. Otherwise, it will display “Please add a valid email address!” under the “Email” input box until the user removes all characters or amends the inputs to follow the correct format.

The dob input:

The last input in the demo app above is dob, a date input, for which we used the sv_required function to declare that it is a required one. Similar to the “Name” input box, the input validator iv will display “Required” under the “Date of birth” text field as long as the dob input is empty. Following that, we added a new rule that used the user-defined function get_age. The get_age function, defined and discussed earlier, requires that we provide two inputs, value and today; where the former is automatically passed to the function by add_rule(), and we passed the latter using the value of Sys.Date().

Should the user’s age be less than 18, iv will display “You are too young to be allowed access to these secure details”. Lastly, the dateInput function ensures that no matter what the user tries, the value attached to the dob inputId will always be a valid date or nothing.

The greeting output:

The only output in this demo app is also controlled by the input validator iv. This server function checks if all the rules attached to the iv input validator were obeyed before it allows the main body of the output function to be processed!

shinyvalidate_demo_app
Running a demo showing shinyvalidate in action

Adding input validation to the Smith et al. (2022) web app:

Below we implement the same ideas we discussed, employing more advanced concepts.

We developed the input validation function dist_input to be flexible to the extent that we would not need to have an input validator for each distribution and each input form (probabilities or utilities). Instead, the idea is to:

  • pass the distribution selected by the user (usually stored in input$p_HS1_dist or input$u_S1_dist) to dist_input() via the dist argument,
  • use the param argument to specify which distribution argument (first or second) the input validator would be validating, and
  • pass the respective distributions’ parameters’ details using the data argument.

Fortunately, we can commence with the plan we laid above thanks to the fact that we can pass one or more formulas to the add_rule function. We demonstrate this feature in the code snippet below, which shows where we injected the input validation functions.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136

server <- function(input, output) {
  ...
  library(waiter)
  # 1. Load the shinyvalidate library:
  library(shinyvalidate)
  
  # 2. Create the parent and children input validators:
  ## Parent input validator:
  model_inputs_iv <- InputValidator$new()
  ## Children input validator:
  probs_iv <- InputValidator$new()
  utils_iv <- InputValidator$new()
  
  # 3. Add children input validators to the Parent input validator:
  model_inputs_iv$add_validator(probs_iv)
  model_inputs_iv$add_validator(utils_iv)
  
  # 4. Define dataframes to be used in the user function below:
  ## Probabilities distributions:
  dists_bounds_probs <- data.frame(
    dist =       c(  "beta", "gamma",  "rlnorm", "fixed"),
    param_1_lb = c(       0,       0,      -Inf,       0),
    param_1_ub = c(     Inf,     Inf,       Inf,       1),
    param_2_lb = c(       0,       0,         0,      NA),
    param_2_ub = c(     Inf,     Inf,     1e300,      NA),
    param_1_nm = c("shape1", "shape", "meanlog", "fixed"),
    param_2_nm = c("shape2", "scale",   "sdlog",      "")
  )
  ## Utilities distributions:
  dists_bounds_utils <- data.frame(
    dist =       c(  "beta", "gamma",  "rlnorm", "fixed"),
    param_1_lb = c(       0,       0,      -Inf,      -1),
    param_1_ub = c(     Inf,     Inf,       Inf,       1),
    param_2_lb = c(       0,       0,         0,      NA),
    param_2_ub = c(     Inf,     Inf,     1e300,      NA),
    param_1_nm = c("shape1", "shape", "meanlog", "fixed"),
    param_2_nm = c("shape2", "scale",   "sdlog",      "")
  )
  
  # 5. Define a function for the input validator: 
  dist_input <- function(value, dist, param, data) {
    dist_bounds <- data[data$dist == dist, -1]
    
    if(param == 1) {
      if(value < dist_bounds[1, param]) {
        if(dist == "fixed") {
          return(
            paste0("The acceptable fixed value should be between ",
                   dist_bounds[1, param], 
                   " and ", 
                   dist_bounds[1, param + 1]
            )
          )}
        return(
          paste0("In a ", dist, " distribution, an acceptable value for the ",
                 dist_bounds[1, param + 4],
                 " parameter should be between ", 
                 dist_bounds[1, param], 
                 " and ", 
                 dist_bounds[1, param + 1]
          )
        )}
      if(value > dist_bounds[1, param + 1]) {
        if(dist == "fixed") {
          return(
            paste0("The acceptable fixed value should be between ",
                   dist_bounds[1, param], 
                   " and ", 
                   dist_bounds[1, param + 1]
            )
          )}
        return(
          paste0("In a ", dist, " distribution, an acceptable value for the ",
                 dist_bounds[1, param + 4],
                 " parameter should be between ", 
                 dist_bounds[1, param], 
                 " and ", 
                 dist_bounds[1, param + 1]
          )
        )}
    } else if (param == 2) {
      if(dist != "fixed"){
        if(value < dist_bounds[1, param + 1]) {
          return(
            paste0("In a ", dist, " distribution, an acceptable value for the ",
                   dist_bounds[1, param + 4],
                   " parameter should be between ", 
                   dist_bounds[1, param + 1], 
                   " and ", 
                   dist_bounds[1, param + 2]
            )
          )
        }}
      if(dist != "fixed"){
        if(value > dist_bounds[1, param + 2]) {
          return(
            paste0("In a ", dist, " distribution, an acceptable value for the ",
                   dist_bounds[1, param + 4],
                   " parameter should be between ", 
                   dist_bounds[1, param + 1], 
                   " and ", 
                   dist_bounds[1, param + 2]
            )
          )
        }}}}
  
  # 6. Attach rules to the child input validators:
  ## Probability input validator:
  probs_iv$condition(~ shiny::isTruthy(input$p_HS1_dist))
  probs_iv$add_rule(inputId = "p_HS1_v1", sv_required())
  probs_iv$add_rule(inputId = "p_HS1_v1", rule = ~ {
    dist_input(value = ., dist = input[["p_HS1_dist"]], param = 1,
               data = dists_bounds_probs)
  })
  probs_iv$add_rule(inputId = "p_HS1_v2", sv_required())
  probs_iv$add_rule(inputId = "p_HS1_v2", rule = ~ {
    dist_input(value = ., dist = input[["p_HS1_dist"]], param = 2, 
               data = dists_bounds_probs)
  })
  ## Utilities input validator:
  utils_iv$condition(~ shiny::isTruthy(input$u_S1_dist))
  probs_iv$add_rule(inputId = "u_S1_v1", sv_required())
  probs_iv$add_rule(inputId = "u_S1_v1", rule = ~ {
    dist_input(value = ., dist = input[["u_S1_dist"]], param = 1,
               data = dists_bounds_utils)
  })
  probs_iv$add_rule(inputId = "u_S1_v2", sv_required())
  probs_iv$add_rule(inputId = "u_S1_v2", rule = ~ {
    dist_input(value = ., dist = input[["u_S1_dist"]], param = 2, 
               data = dists_bounds_utils)
  })
  
  # 7. Start displaying errors in the UI:
  model_inputs_iv$enable()
  ...
}

So, the code chunk above works fine, and shiny no longer throws an error when we pass input$p_HS1_dist or input$u_S1_dist to the function, which itself is now passed on to add_rule() as part of a formula using ~ {}.

Guard calculations until all validations are confirmed:

Finally, let us prevent the model from calling the Application Programming Interface (API) should any of the input validators’ rules fail to pass. We implement this feature by using a conditional statement that depends on the model_inputs_iv$is_valid() being TRUE, or all validations were successful. Should any checks fail, the server function would not call the API, but shiny’s showNotification function would show a pop-up notification informing the user about the issue.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77

list_results <- eventReactive(input$runModel, {
  if(model_inputs_iv$is_valid()) {
    # PS: error message when api key not provided? 
    # Is the API/key supposed accessible to everyone?
    if(Sys.getenv("CONNECT_KEY") == ""){
      shiny::showNotification(type = "error","Error: No API Key provided")
      return(NULL)
    }
    
    # convert inputs into a single data-frame to be passed to the API call
    df_input <- data.frame(
      parameter = c("p_HS1", "u_S1"),
      distribution = c(input$p_HS1_dist, input$u_S1_dist),
      v1 = c(input$p_HS1_v1, input$u_S1_v1),
      v2 = c(input$p_HS1_v2, input$u_S1_v2)
    )
    
    # show modal saying sending to API
    shinybusy::show_modal_gif(text = "Interacting with client API",
                  modal_size = "l",
                  width = "200px", 
                  height = "300px",
                  src = "bean.gif"
                  )
    
    # run the model using the connect server API
    results <- httr::content(
      httr::POST(
        # the Server URL can also be kept confidential, but will leave here for now 
        url = "https://connect.bresmed.com",
        # path for the API within the server URL
        path = "rhta2022/runDARTHmodel",
        # code is passed to the client API from GitHub.
        query = list(model_functions = "https://raw.githubusercontent.com/BresMed/plumberHE/main/R/darth_funcs.R"),
        # set of parameters to be changed ... we are allowed to change these but not some others...
        body = list(
          param_updates = jsonlite::toJSON(df_input)),
        # we include a key here to access the API ... like a password protection

        config = httr::add_headers(Authorization = paste0("Key ", 
                                                          Sys.getenv("CONNECT_KEY")))
      )
    )
    # insert debugging message
    message("API returned results")
    
    # show modal saying finished getting data from API
    shinybusy::remove_modal_gif()
    
    # rename the costs columns
    results_C <- results[,1:3]
    # same for qalys
    results_Q <- results[,4:6]
    # name all the columns the same
    colnames(results_C) <- colnames(results_Q) <- c("A", "B", "C")
    
    # create ceac based on brandtools package from lumanity...
    temp_cols <- c("#D8D2BF", "#001B2B", "#007B84")
    names(temp_cols) <- c("A", "B", "C")
    
    list("results_C" = results_C, 
        "results_Q" = results_Q,
        "temp_cols" = temp_cols)
    
  } else if (!model_inputs_iv$is_valid()) {
    showNotification(
    "Please fix the errors in the parameters' input form before continuing",
    type = "warning"
    )
    if(Sys.getenv("CONNECT_KEY") == "") {
      showNotification(
        "Error: No API Key provided",
        type = "error")
      return(NULL)
    }
  }
})

Code:

The original version of the server.R script:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114

# Define server logic required to draw a histogram
server <- function(input, output) {
  
  library(shiny)
  library(ggplot2)
  library(scales)
  library(reshape2)
  library(shinybusy)
  library(waiter)
  
  source("../report/makeCEAC.R")
  source("../report/makeCEPlane.R")
  source("../app_files/landing_div.R")
  
  list_results <- eventReactive(input$runModel, {
    
    # PS: error message when api key not provided? 
    # Is the API/key supposed accessible to everyone?
    if(Sys.getenv("CONNECT_KEY") == ""){
      shiny::showNotification(type = "error","Error: No API Key provided")
      return(NULL)
    }
    
    # convert inputs into a single data-frame to be passed to the API call
    df_input <- data.frame(
      parameter = c("p_HS1", "u_S1"),
      distribution = c(input$p_HS1_dist, input$u_S1_dist),
      v1 = c(input$p_HS1_v1, input$u_S1_v1),
      v2 = c(input$p_HS1_v2, input$u_S1_v2)
    )
    
    # show modal saying sending to API
    shinybusy::show_modal_gif(text = "Interacting with client API",
                   modal_size = "l",
                   width = "200px", 
                   height = "300px",
                   src = "bean.gif"
                  )
    
    # run the model using the connect server API
    results <- httr::content(
      httr::POST(
        # the Server URL can also be kept confidential, but will leave here for now 
        url = "https://connect.bresmed.com",
        # path for the API within the server URL
        path = "rhta2022/runDARTHmodel",
        # code is passed to the client API from GitHub.
        query = list(model_functions = "https://raw.githubusercontent.com/BresMed/plumberHE/main/R/darth_funcs.R"),
        # set of parameters to be changed ... we are allowed to change these but not some others...
        body = list(
          param_updates = jsonlite::toJSON(df_input)),
        # we include a key here to access the API ... like a password protection

        config = httr::add_headers(Authorization = paste0("Key ", 
                                                          Sys.getenv("CONNECT_KEY")))
      )
    )
    # insert debugging message
    message("API returned results")
    
    # show modal saying finished getting data from API
    shinybusy::remove_modal_gif()
    
    # rename the costs columns
    results_C <- results[,1:3]
    # same for qalys
    results_Q <- results[,4:6]
    # name all the columns the same
    colnames(results_C) <- colnames(results_Q) <- c("A", "B", "C")
    
    # create ceac based on brandtools package from lumanity...
    temp_cols <- c("#D8D2BF", "#001B2B", "#007B84")
    names(temp_cols) <- c("A", "B", "C")
    
    list("results_C" = results_C, 
         "results_Q" = results_Q,
         "temp_cols" = temp_cols)
    
  })
  
    output$CEPlane <- renderPlot({
      
      
      # create the CEP
      makeCEPlane(total_costs = list_results()$results_C,
                  total_qalys = list_results()$results_Q,
                  treatment = "B",
                  comparitor = "A",
                  thresh = 30000,
                  show_ellipse = T,
                  colors = list_results()$temp_cols)

    })
    
    
    output$CEAC <- renderPlot({
      
      makeCEAC(total_costs = list_results()$results_C,
               total_qalys = list_results()$results_Q,
               treatment = c("A", "B", "C"),
               lambda_min = 0,
               lambda_max = 100000,
               col = list_results()$temp_cols)
      
    })
    
    output$ResultsTab_C <- renderTable({
      head(list_results()$results_C)
      })
    
    output$ResultsTab_Q <- renderTable({
      head(list_results()$results_Q)
      })
}

The inputs validated version of the server.R script:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256

# Define server logic required to draw a histogram
server <- function(input, output) {
  
  library(shiny)
  library(ggplot2)
  library(scales)
  library(reshape2)
  library(shinybusy)
  library(waiter)
  # 1. Load the shinyvalidate library:
  library(shinyvalidate)
  
  # 2. Create the parent and children input validators:
  ## Parent input validator:
  model_inputs_iv <- InputValidator$new()
  ## Children input validator:
  probs_iv <- InputValidator$new()
  utils_iv <- InputValidator$new()
  
  # 3. Add children input validators to the Parent input validator:
  model_inputs_iv$add_validator(probs_iv)
  model_inputs_iv$add_validator(utils_iv)
  
  # 4. Define dataframes to be used in the user function below:
  ## Probabilities distributions:
  dists_bounds_probs <- data.frame(
    dist =       c(  "beta", "gamma",  "rlnorm", "fixed"),
    param_1_lb = c(       0,       0,      -Inf,       0),
    param_1_ub = c(     Inf,     Inf,       Inf,       1),
    param_2_lb = c(       0,       0,         0,      NA),
    param_2_ub = c(     Inf,     Inf,     1e300,      NA),
    param_1_nm = c("shape1", "shape", "meanlog", "fixed"),
    param_2_nm = c("shape2", "scale",   "sdlog",      "")
  )
  ## Utilities distributions:
  dists_bounds_utils <- data.frame(
    dist =       c(  "beta", "gamma",  "rlnorm", "fixed"),
    param_1_lb = c(       0,       0,      -Inf,      -1),
    param_1_ub = c(     Inf,     Inf,       Inf,       1),
    param_2_lb = c(       0,       0,         0,      NA),
    param_2_ub = c(     Inf,     Inf,     1e300,      NA),
    param_1_nm = c("shape1", "shape", "meanlog", "fixed"),
    param_2_nm = c("shape2", "scale",   "sdlog",      "")
  )
  
  # 5. Define a function for the input validator: 
  dist_input <- function(value, dist, param, data) {
    dist_bounds <- data[data$dist == dist, -1]
    
    if(param == 1) {
      if(value < dist_bounds[1, param]) {
        if(dist == "fixed") {
          return(
            paste0("The acceptable fixed value should be between ",
                   dist_bounds[1, param], 
                   " and ", 
                   dist_bounds[1, param + 1]
            )
          )}
        return(
          paste0("In a ", dist, " distribution, an acceptable value for the ",
                 dist_bounds[1, param + 4],
                 " parameter should be between ", 
                 dist_bounds[1, param], 
                 " and ", 
                 dist_bounds[1, param + 1]
          )
        )}
      if(value > dist_bounds[1, param + 1]) {
        if(dist == "fixed") {
          return(
            paste0("The acceptable fixed value should be between ",
                   dist_bounds[1, param], 
                   " and ", 
                   dist_bounds[1, param + 1]
            )
          )}
        return(
          paste0("In a ", dist, " distribution, an acceptable value for the ",
                 dist_bounds[1, param + 4],
                 " parameter should be between ", 
                 dist_bounds[1, param], 
                 " and ", 
                 dist_bounds[1, param + 1]
          )
        )}
    } else if (param == 2) {
      if(dist != "fixed"){
        if(value < dist_bounds[1, param + 1]) {
          return(
            paste0("In a ", dist, " distribution, an acceptable value for the ",
                   dist_bounds[1, param + 4],
                   " parameter should be between ", 
                   dist_bounds[1, param + 1], 
                   " and ", 
                   dist_bounds[1, param + 2]
            )
          )
        }}
      if(dist != "fixed"){
        if(value > dist_bounds[1, param + 2]) {
          return(
            paste0("In a ", dist, " distribution, an acceptable value for the ",
                   dist_bounds[1, param + 4],
                   " parameter should be between ", 
                   dist_bounds[1, param + 1], 
                   " and ", 
                   dist_bounds[1, param + 2]
            )
          )
        }}}}
  
  # 6. Attach rules to the child input validators:
  ## Probability input validator:
  probs_iv$condition(~ shiny::isTruthy(input$p_HS1_dist))
  probs_iv$add_rule(inputId = "p_HS1_v1", sv_required())
  probs_iv$add_rule(inputId = "p_HS1_v1", rule = ~ {
    dist_input(value = ., dist = input[["p_HS1_dist"]], param = 1,
               data = dists_bounds_probs)
  })
  probs_iv$add_rule(inputId = "p_HS1_v2", sv_required())
  probs_iv$add_rule(inputId = "p_HS1_v2", rule = ~ {
    dist_input(value = ., dist = input[["p_HS1_dist"]], param = 2, 
               data = dists_bounds_probs)
  })
  ## Utilities input validator:
  utils_iv$condition(~ shiny::isTruthy(input$u_S1_dist))
  probs_iv$add_rule(inputId = "u_S1_v1", sv_required())
  probs_iv$add_rule(inputId = "u_S1_v1", rule = ~ {
    dist_input(value = ., dist = input[["u_S1_dist"]], param = 1,
               data = dists_bounds_utils)
  })
  probs_iv$add_rule(inputId = "u_S1_v2", sv_required())
  probs_iv$add_rule(inputId = "u_S1_v2", rule = ~ {
    dist_input(value = ., dist = input[["u_S1_dist"]], param = 2, 
               data = dists_bounds_utils)
  })
  
  # 7. Start displaying errors in the UI:
  model_inputs_iv$enable()
  
  source("../report/makeCEAC.R")
  source("../report/makeCEPlane.R")
  source("../app_files/landing_div.R")
  
  list_results <- eventReactive(input$runModel, {
    if(model_inputs_iv$is_valid()) {
      # PS: error message when api key not provided? 
      # Is the API/key supposed accessible to everyone?
      if(Sys.getenv("CONNECT_KEY") == ""){
        shiny::showNotification(type = "error","Error: No API Key provided")
        return(NULL)
      }
      
      # convert inputs into a single data-frame to be passed to the API call
      df_input <- data.frame(
        parameter = c("p_HS1", "u_S1"),
        distribution = c(input$p_HS1_dist, input$u_S1_dist),
        v1 = c(input$p_HS1_v1, input$u_S1_v1),
        v2 = c(input$p_HS1_v2, input$u_S1_v2)
      )
      
      # show modal saying sending to API
      shinybusy::show_modal_gif(text = "Interacting with client API",
                                modal_size = "l",
                                width = "200px", 
                                height = "300px",
                                src = "bean.gif"
      )
      
      # run the model using the connect server API
      results <- httr::content(
        httr::POST(
          # the Server URL can also be kept confidential, but will leave here for now 
          url = "https://connect.bresmed.com",
          # path for the API within the server URL
          path = "rhta2022/runDARTHmodel",
          # code is passed to the client API from GitHub.
          query = list(model_functions = "https://raw.githubusercontent.com/BresMed/plumberHE/main/R/darth_funcs.R"),
          # set of parameters to be changed ... we are allowed to change these but not some others...
          body = list(
            param_updates = jsonlite::toJSON(df_input)),
          # we include a key here to access the API ... like a password protection
          
          config = httr::add_headers(Authorization = paste0("Key ", 
                                                            Sys.getenv("CONNECT_KEY")))
        )
      )
      # insert debugging message
      message("API returned results")
      
      # show modal saying finished getting data from API
      shinybusy::remove_modal_gif()
      
      # rename the costs columns
      results_C <- results[,1:3]
      # same for qalys
      results_Q <- results[,4:6]
      # name all the columns the same
      colnames(results_C) <- colnames(results_Q) <- c("A", "B", "C")
      
      # create ceac based on brandtools package from lumanity...
      temp_cols <- c("#D8D2BF", "#001B2B", "#007B84")
      names(temp_cols) <- c("A", "B", "C")
      
      list("results_C" = results_C, 
           "results_Q" = results_Q,
           "temp_cols" = temp_cols)
      
    } else if (!model_inputs_iv$is_valid()) {
      showNotification(
        "Please fix the errors in the parameters' input form before continuing",
        type = "warning"
      )
      if(Sys.getenv("CONNECT_KEY") == "") {
        showNotification(
          "Error: No API Key provided",
          type = "error")
        return(NULL)
      }
    }
  })  
  output$CEPlane <- renderPlot({
    
    
    # create the CEP
    makeCEPlane(total_costs = list_results()$results_C,
                total_qalys = list_results()$results_Q,
                treatment = "B",
                comparitor = "A",
                thresh = 30000,
                show_ellipse = T,
                colors = list_results()$temp_cols)
    
  })
  
  
  output$CEAC <- renderPlot({
    
    makeCEAC(total_costs = list_results()$results_C,
             total_qalys = list_results()$results_Q,
             treatment = c("A", "B", "C"),
             lambda_min = 0,
             lambda_max = 100000,
             col = list_results()$temp_cols)
    
  })
  
  output$ResultsTab_C <- renderTable({
    head(list_results()$results_C)
  })
  
  output$ResultsTab_Q <- renderTable({
    head(list_results()$results_Q)
  })
}

Conclusion:

In this tutorial, we demonstrated the validation of user inputs in a shiny-powered web application. While this process could be achieved in several ways or using several packages, we used the shinyvalidate package, which provides a bunch of goodies, including its use of R6 classes.

Sources:

  1. https://rstudio.github.io/shinyvalidate/index.html ↩

R, R packages, shinyvalidate
shiny shinyvalidate r packages
This post is licensed under CC BY 4.0 by the author.
Recently Updated
Contents