tests/testthat/test-checks.R

In REDCapTidieR: Extract 'REDCap' Databases into Tidy 'Tibble's

test_that("check_user_rights works", {
  test_data <- tibble::tribble(
    ~record_id, ~field_1,  ~field_2,
    1,          "1",       "2"
  )

  test_data_empty <- tibble::tribble(
    ~record_id,
    1
  )

  test_metadata <- tibble::tribble(
    ~field_name_updated, ~form_name,
    "record_id",         NA_character_,
    "field_1",           "form_1",
    "field_2",           "form_2",
    "missing_field",     "missing_form",
    "missing_field_2",   "missing_form",
    "missing_field_3",   "missing_form2"
  )

  expect_warning(
    check_user_rights(test_data, test_metadata),
    class = "partial_data_access"
  )

  expect_error(
    check_user_rights(test_data_empty, test_metadata),
    class = "no_data_access"
  )
})

test_that("check_repeat_and_nonrepeat works", {
  test_data_longitudinal <- tibble::tribble(
    ~record_id,  ~redcap_event_name, ~redcap_repeat_instrument, ~redcap_repeat_instance, ~combination_variable,
    1,           "event_1",          NA,                        NA,                      "A",
    2,           "event_2",          "combination",             1,                       "B",
    3,           "event_3",          "combination",             2,                       "C"
  )

  test_data_not_longitudinal <- tibble::tribble(
    ~new_record_id,  ~redcap_repeat_instrument, ~redcap_repeat_instance, ~combination_variable,
    1,               NA,                        NA,                      "A",
    2,               "combination",             1,                       "B",
    3,               "combination",             2,                       "C"
  )

  test_repeating_event <- tibble::tribble(
    ~record_id, ~redcap_repeat_instrument, ~redcap_repeat_instance, ~combination_variable,
    1, NA, NA, "A",
    1, NA, 1, "B",
    2, "combination", 2, NA
  )

  expect_error(check_repeat_and_nonrepeat(db_data = test_data_longitudinal),
    class = "repeat_nonrepeat_instrument"
  )
  expect_error(check_repeat_and_nonrepeat(db_data = test_data_not_longitudinal),
    class = "repeat_nonrepeat_instrument"
  )
  expect_no_error(check_repeat_and_nonrepeat(db_data = test_repeating_event))
})

test_that("check_redcap_populated works", {
  test_data <- tibble()

  expect_error(check_redcap_populated(db_data = test_data), class = "redcap_unpopulated")
})

test_that("check_forms_exist works", {
  metadata <- tibble(form_name = letters[1:4])
  forms <- letters[3:6]

  expect_error(check_forms_exist(metadata, forms), regexp = "e and f")
})

test_that("check_req_labelled_metadata_fields works", {
  # Check field_name and field_label within metadata
  supertbl_no_field_name <- tibble::tribble(
    ~redcap_data, ~redcap_metadata,
    tibble(x = letters[1:3]), tibble(field_label = "X Label"),
    tibble(y = letters[1:3]), tibble(field_label = "Y Label")
  )

  supertbl_no_field_label <- tibble::tribble(
    ~redcap_data, ~redcap_metadata,
    tibble(x = letters[1:3]), tibble(field_name = "x"),
    tibble(y = letters[1:3]), tibble(field_name = "y")
  )

  ## Errors when field_name is missing
  check_req_labelled_metadata_fields(supertbl_no_field_name) %>%
    expect_error(class = "missing_req_labelled_metadata_fields")

  ## Errors when field_label is missing
  check_req_labelled_metadata_fields(supertbl_no_field_label) %>%
    expect_error(class = "missing_req_labelled_metadata_fields")
})

test_that("check_parsed_labels works", {
  check_parsed_labels(letters[1:2], "field_name") %>%
    expect_no_warning()

  cnd <- check_parsed_labels(rep("a", 2), "field_name") %>%
    rlang::catch_cnd(classes = "duplicate_labels")

  expect_equal(cnd$field, "field_name")

  cnd <- check_parsed_labels(c(a = ""), "field_name") %>%
    rlang::catch_cnd(classes = "blank_labels")

  expect_equal(cnd$field, "field_name")
})

test_that("checkmate wrappers work", {
  # supertbl
  expect_error(check_arg_is_supertbl(123), class = "check_supertbl")

  missing_col_supertbl <- tibble(redcap_data = list()) %>%
    as_supertbl()

  missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) %>%
    as_supertbl()

  good_supertbl <- tibble(redcap_data = list(), redcap_metadata = list()) %>%
    as_supertbl()

  expect_error(check_arg_is_supertbl(missing_col_supertbl), class = "missing_req_cols")
  expect_error(check_arg_is_supertbl(missing_list_col_supertbl), class = "missing_req_list_cols")
  expect_true(check_arg_is_supertbl(good_supertbl))

  # environment
  expect_error(check_arg_is_env(123), class = "check_environment")
  expect_true(check_arg_is_env(new.env()))

  # character
  expect_error(check_arg_is_character(123), class = "check_character")
  expect_true(check_arg_is_character("abc"))

  # logical
  expect_error(check_arg_is_logical(123), class = "check_logical")
  expect_true(check_arg_is_logical(TRUE))

  # choices
  expect_error(check_arg_choices(123, choices = letters[1:3]), class = "check_choice")
  expect_true(check_arg_choices("a", choices = letters[1:3]))

  # token
  expect_error(check_arg_is_valid_token("abc"), class = "invalid_token")
  expect_true(check_arg_is_valid_token("123456789ABCDEF123456789ABCDEF01"))

  # extension
  expect_warning(check_arg_is_valid_extension("temp.docx", valid_extensions = "xlsx"),
    class = "invalid_file_extension"
  )
  expect_warning(check_arg_is_valid_extension("xlsx.", valid_extensions = "xlsx"),
    class = "invalid_file_extension"
  )
  expect_true(check_arg_is_valid_extension("temp.xlsx", valid_extensions = "xlsx"))
})

test_that("check_data_arg_exists works", {
  missing_fields <- tibble::tribble(
    ~record_id, ~field_1,
    1,          "1"
  )

  included_fields <- tibble::tribble(
    ~record_id, ~redcap_data_access_group, ~redcap_survey_identifier, ~field_1,
    1, "A", NA, "1"
  )

  expect_error(
    check_data_arg_exists(
      db_data = missing_fields,
      col = "redcap_data_access_group",
      arg = "export_data_access_groups"
    ),
    class = "nonexistent_arg_requested"
  )
  expect_no_error(
    check_data_arg_exists(
      db_data = included_fields,
      col = "redcap_data_access_group",
      arg = "export_data_access_groups"
    ),
    class = "nonexistent_arg_requested"
  )
  expect_error(
    check_data_arg_exists(
      db_data = missing_fields,
      col = "redcap_survey_identifier",
      arg = "export_survey_fields"
    ),
    class = "nonexistent_arg_requested"
  )
  expect_no_error(
    check_data_arg_exists(
      db_data = included_fields,
      col = "redcap_survey_identifier",
      arg = "export_survey_fields"
    ),
    class = "nonexistent_arg_requested"
  )
})

test_that("check_file_exists works", {
  withr::with_tempdir({
    dir <- getwd()
    filepath <- paste0(dir, "/temp.csv")
    expect_no_error(
      check_file_exists(file = filepath, overwrite = FALSE)
    )
  })

  withr::with_tempdir({
    dir <- getwd()
    tempfile <- write.csv(x = mtcars, file = "temp.csv")
    filepath <- paste0(dir, "/temp.csv")
    expect_error(
      check_file_exists(file = filepath, overwrite = FALSE),
      class = "check_file_overwrite"
    )
  })
})

test_that("check_field_is_logical works", {
  expect_equal(
    check_field_is_logical(c(TRUE, FALSE, NA)),
    list(parsed = c(TRUE, FALSE, NA), problems = NULL)
  )
  expect_equal(
    check_field_is_logical(c(1, 0, NA)),
    list(parsed = c(TRUE, FALSE, NA), problems = NULL)
  )
  expect_equal(
    check_field_is_logical(c(1, 0, "x")),
    list(parsed = c(TRUE, FALSE, NA), problems = "x")
  )
})

test_that("check_extra_field_values works", {
  check_extra_field_values(c(1, NA, 2), c("1", "2")) |>
    expect_null()

  check_extra_field_values(c(1, NA, 2), "1") |>
    expect_equal("2")
})

test_that("check_fields_exist works", {
  check_fields_exist(fields = character(0), expr = expr(starts_with("temp"))) %>%
    expect_error(class = "missing_checkbox_fields")

  check_fields_exist(fields = c(1, 2, 3), expr = expr(starts_with("temp"))) %>%
    expect_no_error()
})

test_that("check_metadata_fields_exist works", {
  metadata_valid <- tibble(
    field_name = c("var1", "var2", "var_3"),
  )
  valid_cols <- c("var1", "var2", "var_3")

  metadata_invalid <- tibble(
    field_name = c("var1", "var2", "var_3_edited"),
  )
  invalid_cols <- c("var1", "var2", "var_3_edited")

  check_metadata_fields_exist(metadata_valid, valid_cols) %>%
    expect_no_error()

  check_metadata_fields_exist(metadata_invalid, valid_cols) %>%
    expect_error(class = "missing_metadata_checkbox_fields")

  check_metadata_fields_exist(metadata_valid, invalid_cols) %>%
    expect_error(class = "missing_metadata_checkbox_fields")
})

test_that("check_fields_are_checkboxes works", {
  metadata <- tibble::tribble(
    ~field_name, ~field_type,
    "record_id", "text",
    "text_field", "text",
    "calc_field", "calc",
    "checkbox___1", "checkbox",
    "checkbox___2", "checkbox",
    "checkbox___3", "checkbox"
  )

  metadata_filtered <- metadata %>%
    filter("checkbox" %in% field_name)

  expect_error(check_fields_are_checkboxes(metadata), class = "non_checkbox_fields")
  expect_no_error(check_fields_are_checkboxes(metadata_filtered))
})

test_that("check_equal_col_summaries works", {
  data <- tibble::tribble(
    ~"id", ~"col1", ~"col2",
    1, "A", "A1",
    2, "B", "B1",
    3, "C", "C1"
  )

  expect_no_error(check_equal_col_summaries(data, col1, col2))

  error_data <- tibble::tribble(
    ~"id", ~"col1", ~"col2",
    1, "A", "A1",
    2, "A", "A2",
    3, "B", "B1",
    4, "B", "B2"
  )

  check_equal_col_summaries(error_data, col1, col2) %>%
    expect_error(class = "names_glue_multi_checkbox")
})