tests/testthat/test-modules.R

In teal: Exploratory Web Apps for Analyzing Clinical Trials Data

call_module_server_fun <- function(input, output, session, data) {
}

module_server_fun <- function(id, data) {
}

ui_fun1 <- function(id, ...) {
  tags$p(paste0("id: ", id))
}

testthat::test_that("Calling module() does not throw", {
  testthat::expect_no_error(suppressMessages(module()))
})

testthat::test_that("module requires label argument to be a string different than 'global_filters'", {
  testthat::expect_no_error(module(label = "label"))

  testthat::expect_error(module(label = NULL), "Assertion on 'label' failed.+'NULL'")

  testthat::expect_error(module(label = c("label", "label")), "Assertion on 'label' failed: Must have length 1.")

  testthat::expect_error(module(label = 1L), "Assertion on 'label' failed.+not 'integer'")

  testthat::expect_error(module(label = "global_filters"), "is reserved in teal")
})

testthat::test_that("module warns when server contains datasets argument", {
  testthat::expect_warning(
    module(server = function(id, datasets) NULL),
    "`datasets` argument in the server is deprecated"
  )
})


testthat::test_that("module expects server being a shiny server module with any argument", {
  testthat::expect_no_error(module(server = function(id) NULL))

  testthat::expect_no_error(module(server = function(id, any_argument) NULL))

  testthat::expect_no_error(module(server = function(input, output, session, any_argument) NULL))


  testthat::expect_error(
    module(server = function(input, output) NULL),
    "`server` argument requires a function with following arguments"
  )

  testthat::expect_error(
    module(server = function(any_argument) NULL),
    "`server` argument requires a function with following arguments"
  )
})

testthat::test_that("module requires server_args argument to be a list", {
  testthat::expect_no_error(module(server = function(id, a) NULL, server_args = list(a = 1)))
  testthat::expect_no_error(module(server_args = list()))
  testthat::expect_no_error(module(server_args = NULL))
  testthat::expect_error(module(server_args = ""), "Assertion on 'server_args' failed.+'list'")
  testthat::expect_error(module(server_args = list(1, 2, 3)), "Must have names")
})

testthat::test_that("module expects all server_args being a server arguments or passed through `...`", {
  testthat::expect_no_error(module(server = function(id, arg1) NULL, server_args = list(arg1 = NULL)))

  testthat::expect_no_error(module(server = function(id, ...) NULL, server_args = list(arg1 = NULL)))

  testthat::expect_error(
    module(server = function(id) NULL, server_args = list(arg1 = NULL)),
    "Following `server_args` elements have no equivalent in the formals of the server"
  )
})

testthat::test_that("module requires ui_args argument to be a list", {
  testthat::expect_no_error(module(ui = function(id, a) NULL, ui_args = list(a = 1)))
  testthat::expect_no_error(module(ui_args = list()))
  testthat::expect_no_error(module(ui_args = NULL))
  testthat::expect_error(module(ui_args = ""), "Assertion on 'ui_args' failed.+'list'")
  testthat::expect_error(module(ui_args = list(1, 2, 3)), "Must have names")
})

testthat::test_that("module throws when ui has data or datasets argument", {
  testthat::expect_error(module(ui = function(id, data) NULL))
  testthat::expect_error(module(ui = function(id, datasets) NULL))
})

testthat::test_that("module expects ui being a shiny ui module with any argument", {
  testthat::expect_no_error(module(ui = function(id) NULL))
  testthat::expect_no_error(module(ui = function(id, any_argument) NULL))
  testthat::expect_error(
    module(ui = function(any_argument) NULL),
    "`ui` argument requires a function with following arguments"
  )
})

testthat::test_that("module expects all ui_args being a ui arguments or passed through `...`", {
  testthat::expect_no_error(module(ui = function(id, arg1) NULL, ui_args = list(arg1 = NULL)))

  testthat::expect_no_error(module(ui = function(id, ...) NULL, ui_args = list(arg1 = NULL)))

  testthat::expect_error(
    module(ui = function(id) NULL, ui_args = list(arg1 = NULL)),
    "Following `ui_args` elements have no equivalent in the formals of UI"
  )
})

testthat::test_that("module requires datanames argument to be a character or NULL", {
  testthat::expect_no_error(module(datanames = "all"))
  testthat::expect_no_error(module(datanames = ""))
  testthat::expect_no_error(module(datanames = NULL))
  testthat::expect_error(module(server = function(id, data) NULL, datanames = NA_character_), "Contains missing values")
  testthat::expect_no_error(module(server = function(id, data) NULL, datanames = NULL))
})

testthat::test_that("module() returns list of class 'teal_module' containing input objects", {
  test_module <- module(
    label = "aaa1",
    server = call_module_server_fun,
    ui = ui_fun1,
    datanames = "all",
    server_args = NULL,
    ui_args = NULL
  )
  testthat::expect_s3_class(test_module, "teal_module")
  testthat::expect_named(test_module, c("label", "server", "ui", "datanames", "server_args", "ui_args"))
  testthat::expect_identical(test_module$label, "aaa1")
  testthat::expect_identical(test_module$server, call_module_server_fun)
  testthat::expect_identical(test_module$ui, ui_fun1)
  testthat::expect_identical(test_module$datanames, "all")
  testthat::expect_identical(test_module$server_args, NULL)
  testthat::expect_identical(test_module$ui_args, NULL)
})

testthat::test_that("modules gives error if no arguments other than label are used", {
  testthat::expect_error(modules(label = "my label"))
  testthat::expect_error(modules()) # using default label argument
})

testthat::test_that("modules requires label argument to be a string ", {
  test_module <- module(
    label = "label",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )

  testthat::expect_no_error(modules(label = "label", test_module))
  testthat::expect_error(modules(label = NULL, test_module), "Assertion on 'label' failed.+'NULL'")
  testthat::expect_error(
    modules(label = c("label", "label"), test_module),
    "Assertion on 'label' failed: Must have length 1"
  )
})

testthat::test_that("modules accept teal_module in ...", {
  test_module <- module(
    label = "label",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )

  testthat::expect_no_error(modules(label = "label", test_module))
})

testthat::test_that("modules accept multiple teal_module objects in ...", {
  test_module <- module(
    label = "label",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )

  testthat::expect_no_error(modules(label = "label", test_module, test_module))
})

testthat::test_that("modules accept multiple teal_module and teal_modules objects in ...", {
  test_module <- module(
    label = "label",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )
  test_modules <- modules(label = "label", test_module)

  testthat::expect_no_error(modules(label = "label", test_module, test_modules))
})

testthat::test_that("modules does not accept objects other than teal_module(s) in ...", {
  testthat::expect_error(
    modules(label = "label", 5),
    "the following types: \\{teal_module,teal_modules\\}",
  )
})

testthat::test_that("modules does not accept objects other than teal_module(s) in ...", {
  testthat::expect_error(
    modules(label = "label", "a"),
    "The only character argument to modules\\(\\) must be 'label'",
  )
})

testthat::test_that("modules returns teal_modules object with label and children slot", {
  test_module <- module(
    label = "label",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )
  out <- modules(label = "label2", test_module)
  testthat::expect_s3_class(out, "teal_modules")
  testthat::expect_named(out, c("label", "children"))
})

testthat::test_that("modules returns children as list with list named after label attributes", {
  test_module <- module(
    label = "module",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )
  test_modules <- modules(label = "modules", test_module)
  out <- modules(label = "tabs", test_module, test_modules)$children
  testthat::expect_named(out, c("module", "modules"))
  testthat::expect_identical(out$module, test_module)
  testthat::expect_identical(out$modules, test_modules)
})


testthat::test_that("modules returns useful error message if label argument not explicitly named", {
  test_module <- module(
    label = "module",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )
  testthat::expect_error(
    modules("module", test_module),
    "The only character argument to modules\\(\\) must be 'label'"
  )
})


testthat::test_that("modules returns children as list with unique names if labels are duplicated", {
  test_module <- module(
    label = "module",
    server = module_server_fun,
    ui = ui_fun1,
    datanames = ""
  )
  test_modules <- modules(label = "module", test_module)
  out <- modules(label = "tabs", test_module, test_modules)$children
  testthat::expect_named(out, c("module", "module_1"))
  testthat::expect_identical(out$module, test_module)
  testthat::expect_identical(out$module_1, test_modules)
})


testthat::test_that("modules_depth accepts depth as integer", {
  testthat::expect_no_error(
    modules_depth(
      module(
        label = "label",
        server = module_server_fun,
        ui = ui_fun1,
        datanames = ""
      ),
      depth = 3L
    )
  )

  testthat::expect_error(
    modules_depth(
      module(
        label = "label",
        server = module_server_fun,
        ui = ui_fun1,
        datanames = ""
      ),
      depth = "1"
    ),
    "Assertion on 'depth' failed.+'character'"
  )
})

testthat::test_that("modules_depth returns depth=0 by default", {
  testthat::expect_identical(
    modules_depth(
      module(
        label = "label",
        server = module_server_fun,
        ui = ui_fun1,
        datanames = ""
      )
    ),
    0L
  )
})

testthat::test_that("modules_depth accepts modules to be teal_module or teal_modules", {
  testthat::expect_no_error(
    modules_depth(
      module(
        label = "label",
        server = module_server_fun,
        ui = ui_fun1,
        datanames = ""
      )
    )
  )
  testthat::expect_no_error(
    modules_depth(
      modules(
        label = "tabs",
        module(
          label = "label",
          server = module_server_fun,
          ui = ui_fun1,
          datanames = ""
        )
      )
    )
  )
})

testthat::test_that("modules_depth returns depth same as input for teal_module", {
  testthat::expect_identical(
    modules_depth(
      module(
        label = "label",
        server = module_server_fun,
        ui = ui_fun1,
        datanames = ""
      )
    ),
    0L
  )
})

testthat::test_that("modules_depth increases depth by 1 for each teal_modules", {
  testthat::expect_identical(
    modules_depth(
      modules(
        label = "tabs",
        module(
          label = "label",
          server = module_server_fun,
          ui = ui_fun1,
          datanames = ""
        )
      ),
      depth = 1L
    ),
    2L
  )

  testthat::expect_identical(
    modules_depth(
      modules(
        label = "tabs",
        modules(
          label = "tabs",
          module(
            label = "label",
            server = module_server_fun,
            ui = ui_fun1,
            datanames = ""
          )
        )
      ),
      depth = 1L
    ),
    3L
  )
})


# is_arg_used -----
get_srv_and_ui <- function() {
  list(
    server_fun = function(id, datasets) {},
    ui_fun = function(id, ...) {
      tags$p(paste0("id: ", id))
    }
  )
}

testthat::test_that("is_arg_used throws error if object is not teal_module or teal_modules", {
  testthat::expect_error(is_arg_used(5, "reporter"), "is_arg_used function not implemented for this object")
  testthat::expect_error(is_arg_used(list(), "reporter"), "is_arg_used function not implemented for this object")
})

testthat::test_that("is_arg_used returns true if teal_module has given `arg` in server function args", {
  testthat::expect_true(is_arg_used(module(server = function(id, data, reporter) NULL), "reporter"))
})

testthat::test_that("is_arg_used returns false if teal_module does not have reporter in server function args", {
  testthat::expect_false(is_arg_used(module(), "reporter"))
})


testthat::test_that("is_arg_used returns false if teal_modules has no children using given `arg`", {
  mod <- module()
  mods <- modules(label = "lab", mod, mod)
  testthat::expect_false(is_arg_used(mods, "reporter"))

  mods <- modules(label = "lab", mods, mod, mod)
  testthat::expect_false(is_arg_used(mods, "reporter"))
})

testthat::test_that("is_arg_used returns true if teal_modules has at least one child using given `arg`", {
  server_fun_with_reporter <- function(id, data, reporter) NULL

  mod <- module()
  mod_with_reporter <- module(server = server_fun_with_reporter)

  mods <- modules(label = "lab", mod, mod_with_reporter)
  testthat::expect_true(is_arg_used(mods, "reporter"))

  mods_2 <- modules(label = "lab", mods, mod, mod)
  testthat::expect_true(is_arg_used(mods_2, "reporter"))

  mods_3 <- modules(label = "lab", modules(label = "lab", mod, mod), mod_with_reporter, mod)
  testthat::expect_true(is_arg_used(mods_3, "reporter"))
})

testthat::test_that("is_arg_used returns TRUE/FALSE when the `arg` is in function formals", {
  testthat::expect_true(is_arg_used(function(x) NULL, "x"))
  testthat::expect_false(is_arg_used(function(x) NULL, "y"))
})

testthat::test_that("is_arg_used accepts `arg` to be a string only", {
  testthat::expect_error(is_arg_used(function(x) NULL, c("x", "y")))
  testthat::expect_error(is_arg_used(function(x) NULL, 1))
  testthat::expect_error(is_arg_used(function(x) NULL, NULL))
})


# ---- append_module
testthat::test_that("append_module throws error when modules is not inherited from teal_modules", {
  testthat::expect_error(
    append_module(module(), module()),
    "Assertion on 'modules' failed: Must inherit from class 'teal_modules'"
  )

  testthat::expect_error(
    append_module(module(), list(module())),
    "Assertion on 'modules' failed: Must inherit from class 'teal_modules'"
  )
})

testthat::test_that("append_module throws error is module is not inherited from teal_module", {
  mod <- module()
  mods <- modules(label = "A", mod)

  testthat::expect_error(
    append_module(mods, mods),
    "Assertion on 'module' failed: Must inherit from class 'teal_module'"
  )

  testthat::expect_error(
    append_module(mods, list(mod)),
    "Assertion on 'module' failed: Must inherit from class 'teal_module'"
  )
})

testthat::test_that("append_module appends a module to children of not nested teal_modules", {
  mod <- module(label = "a")
  mod2 <- module(label = "b")
  mods <- modules(label = "c", mod, mod2)
  mod3 <- module(label = "d")

  appended_mods <- append_module(mods, mod3)
  testthat::expect_equal(appended_mods$children, list(a = mod, b = mod2, d = mod3))
})


testthat::test_that("append_module appends a module to children of nested teal_modules", {
  mod <- module(label = "a")
  mod2 <- module(label = "b")
  mods <- modules(label = "c", mod)
  mods2 <- modules(label = "e", mods, mod2)
  mod3 <- module(label = "d")

  appended_mods <- append_module(mods2, mod3)
  testthat::expect_equal(appended_mods$children, list(c = mods, b = mod2, d = mod3))
})

testthat::test_that("append_module produces teal_modules with unique named children", {
  mod <- module(label = "a")
  mod2 <- module(label = "c")
  mods <- modules(label = "c", mod, mod2)
  mod3 <- module(label = "c")

  appended_mods <- append_module(mods, mod3)
  mod_names <- names(appended_mods$children)
  testthat::expect_equal(mod_names, unique(mod_names))
})


# format ----------------------------------------------------------------------------------------------------------

testthat::test_that("format.teal_modules returns proper structure", {
  mod <- module(label = "a")
  mod2 <- module(label = "c")
  mods <- modules(label = "c", mod, mod2)
  mod3 <- module(label = "c")

  appended_mods <- append_module(mods, mod3)

  testthat::expect_equal(
    format(appended_mods),
    "+ c\n + a\n + c\n + c\n"
  )
})