tests/testthat/test-validate_inputs.R

In teal: Exploratory Web Apps for Analyzing Clinical Trials Data

testthat::test_that("invalid arguments raise errors", {
  testthat::expect_error(
    validate_inputs("string"),
    "validate_inputs accepts validators or a list thereof"
  )
  testthat::expect_error(
    validate_inputs(list("name" = "string")),
    "validate_inputs accepts validators or a list thereof"
  )
})


testthat::test_that("disabled validators raise warnings (individual validators)", {
  server <- function(input, output, session) {
    iv1 <- shinyvalidate::InputValidator$new()
    iv1$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv1$enable()
    iv2 <- shinyvalidate::InputValidator$new()
    iv2$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    values <- shiny::reactive({
      validate_inputs(iv1, iv2)
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    testthat::expect_warning(
      object = values(),
      regexp = "Validator is disabled and will be omitted."
    )
  })
})


testthat::test_that("disabled validators raise warnings (validator list)", {
  server <- function(input, output, session) {
    iv1 <- shinyvalidate::InputValidator$new()
    iv1$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv1$enable()
    iv2 <- shinyvalidate::InputValidator$new()
    iv2$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    values <- shiny::reactive({
      validate_inputs(list(iv1, iv2))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    testthat::expect_warning(
      object = values(),
      regexp = "Validator is disabled and will be omitted."
    )
  })
})


testthat::test_that("disabled validators raise warnings (nested validator list)", {
  server <- function(input, output, session) {
    iv1 <- shinyvalidate::InputValidator$new()
    iv1$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv1$enable()
    iv2 <- shinyvalidate::InputValidator$new()
    iv2$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    values <- shiny::reactive({
      validate_inputs(list(list(iv1), list(iv2)))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    testthat::expect_warning(
      object = values(),
      regexp = "Validator is disabled and will be omitted."
    )
  })
})


testthat::test_that("valid inputs produce desired output (individual validators)", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    values <- shiny::reactive({
      validate_inputs(iv)
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "A",
      "number" = 2L
    )
    testthat::expect_identical(values(), list(
      "letter" = input[["letter"]],
      "number" = input[["number"]]
    ))
  })
})


testthat::test_that("valid inputs produce desired output (validator list)", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    values <- shiny::reactive({
      validate_inputs(list(iv))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "A",
      "number" = 2L
    )
    testthat::expect_identical(values(), list(
      "letter" = input[["letter"]],
      "number" = input[["number"]]
    ))
  })
})


testthat::test_that("valid inputs produce desired output (nested validator list)", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    values <- shiny::reactive({
      validate_inputs(list(list(iv)))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "A",
      "number" = 2L
    )
    testthat::expect_identical(values(), list(
      "letter" = input[["letter"]],
      "number" = input[["number"]]
    ))
  })
})


testthat::test_that("invalid inputs raise errors in output (individual validators)", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    values <- shiny::reactive({
      validate_inputs(iv)
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 2L
    )
    testthat::expect_error(values(), "choose a capital letter")
  })
  shiny::testServer(server, {
    session$setInputs(
      "letter" = "A",
      "number" = 1L
    )
    testthat::expect_error(values(), "choose an even number")
  })
  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 1L
    )
    testthat::expect_error(values(), "choose a capital letter.+choose an even number")
  })
})


testthat::test_that("invalid inputs raise errors in output (validator list)", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    values <- shiny::reactive({
      validate_inputs(list(iv))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 2L
    )
    testthat::expect_error(values(), "choose a capital letter")
  })
  shiny::testServer(server, {
    session$setInputs(
      "letter" = "A",
      "number" = 1L
    )
    testthat::expect_error(values(), "choose an even number")
  })
  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 1L
    )
    testthat::expect_error(values(), "choose a capital letter.+choose an even number")
  })
})

testthat::test_that("invalid inputs raise errors in output (nested validator list)", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    values <- shiny::reactive({
      validate_inputs(list(list(iv)))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 2L
    )
    testthat::expect_error(values(), "choose a capital letter")
  })
  shiny::testServer(server, {
    session$setInputs(
      "letter" = "A",
      "number" = 1L
    )
    testthat::expect_error(values(), "choose an even number")
  })
  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 1L
    )
    testthat::expect_error(values(), "choose a capital letter.+choose an even number")
  })
})


testthat::test_that("error message is formatted properly", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    iv_par <- shinyvalidate::InputValidator$new()
    iv_par$add_rule("color", shinyvalidate::sv_required(message = "choose a color"))
    iv_par$add_rule(
      "size",
      shinyvalidate::sv_between(
        left = 0.5, right = 3,
        message_fmt = "choose a value between {left} and {right}"
      )
    )
    iv_par$enable()
  }

  shiny::testServer(server, {
    session$setInputs(
      "letter" = "a",
      "number" = 1L,
      "color" = "",
      "size" = 0.25
    )

    # check error class
    testthat::expect_error(validate_inputs(iv), class = "shiny.silent.error")
    testthat::expect_error(validate_inputs(iv, iv_par), class = "shiny.silent.error")
    testthat::expect_error(validate_inputs(list(iv)), class = "shiny.silent.error")
    testthat::expect_error(validate_inputs(list(iv, iv_par)), class = "shiny.silent.error")
    testthat::expect_error(validate_inputs(list(iv, list(iv_par))), class = "shiny.silent.error")

    # check error message
    errmess <- tryCatch(validate_inputs(iv), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Some inputs require attention\n",
        "choose a capital letter",
        "choose an even number",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(validate_inputs(iv, iv_par), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Some inputs require attention\n",
        "choose a capital letter",
        "choose an even number",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(validate_inputs(list(iv)), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Some inputs require attention\n",
        "choose a capital letter",
        "choose an even number",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(validate_inputs(list(iv, iv_par)), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Some inputs require attention\n",
        "choose a capital letter",
        "choose an even number",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(validate_inputs(list(iv, list(iv_par))), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Some inputs require attention\n",
        "choose a capital letter",
        "choose an even number",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    # check custom headers
    errmess <- tryCatch(validate_inputs(iv, header = "Header message"), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Header message\n",
        "choose a capital letter",
        "choose an even number",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(validate_inputs(iv, iv_par, header = "Header message"), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Header message\n",
        "choose a capital letter",
        "choose an even number",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(validate_inputs(list("Header message" = iv)), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Header message\n",
        "choose a capital letter",
        "choose an even number",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(
      validate_inputs(list(
        "Header message 1" = iv,
        "Header message 2" = iv_par
      )),
      error = function(e) e$message
    )
    testthat::expect_identical(errmess, paste(
      c(
        "Header message 1\n",
        "choose a capital letter",
        "choose an even number",
        "\n",
        "Header message 2\n",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(
      validate_inputs(list(
        "Header message 1" = iv,
        list(
          "Header message 2" = iv_par
        )
      )),
      error = function(e) e$message
    )
    testthat::expect_identical(errmess, paste(
      c(
        "Header message 1\n",
        "choose a capital letter",
        "choose an even number",
        "\n",
        "Header message 2\n",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(
      validate_inputs(list(
        iv,
        "Header message" = iv_par
      )),
      error = function(e) e$message
    )
    testthat::expect_identical(errmess, paste(
      c(
        "choose a capital letter",
        "choose an even number",
        "Header message\n",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))
  })
})


testthat::test_that("different validation modes produce proper messages", {
  server <- function(input, output, session) {
    iv <- shinyvalidate::InputValidator$new()
    iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter"))
    iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
    iv$enable()
    iv_par <- shinyvalidate::InputValidator$new()
    iv_par$add_rule("color", shinyvalidate::sv_required(message = "choose a color"))
    iv_par$add_rule(
      "size",
      shinyvalidate::sv_between(
        left = 0.5, right = 3,
        message_fmt = "choose a value between {left} and {right}"
      )
    )
    iv_par$enable()

    values_h <- shiny::reactive({
      validate_inputs(iv, header = "Main validator")
      validate_inputs(iv_par, header = "Graphical validator")
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]],
        "color" = input[["color"]],
        "size" = input[["size"]]
      )
    })
    values_c <- shiny::reactive({
      validate_inputs(iv, iv_par, header = "Both validators")
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]],
        "color" = input[["color"]],
        "size" = input[["size"]]
      )
    })
    values_g <- shiny::reactive({
      validate_inputs(list("Main validator" = iv, "Graphical validator" = iv_par))
      list(
        "letter" = input[["letter"]],
        "number" = input[["number"]],
        "color" = input[["color"]],
        "size" = input[["size"]]
      )
    })
  }

  shiny::testServer(server, {
    session$setInputs(
      "method" = "hierarchical",
      "letter" = "a",
      "number" = 1L,
      "color" = "",
      "size" = 0.25
    )

    errmess <- tryCatch(values_h(), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Main validator\n",
        "choose a capital letter",
        "choose an even number",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(values_c(), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Both validators\n",
        "choose a capital letter",
        "choose an even number",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))

    errmess <- tryCatch(values_g(), error = function(e) e$message)
    testthat::expect_identical(errmess, paste(
      c(
        "Main validator\n",
        "choose a capital letter",
        "choose an even number",
        "\n",
        "Graphical validator\n",
        "choose a color",
        "choose a value between 0.5 and 3",
        "\n"
      ),
      collapse = "\n"
    ))
  })
})