tests/testthat/test-write.R

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

redcap_data_a <- tibble::tribble(
  ~record_id, ~col_a,
  1,          "A"
)

redcap_metadata_a <- tibble::tribble(
  ~field_name, ~field_label, ~field_type,
  "record_id", "Record ID", "text",
  "col_a", "Label A", "text"
)

redcap_data_b <- tibble::tribble(
  ~record_id, ~col_b,
  1,          "B"
)

redcap_metadata_b <- tibble::tribble(
  ~field_name, ~field_label, ~field_type,
  "record_id", "Record ID", "text",
  "col_b", "Label B", "text"
)

supertbl <- tibble::tribble(
  ~redcap_form_name, ~redcap_form_label, ~redcap_data, ~redcap_metadata,
  "a", "A", redcap_data_a, redcap_metadata_a,
  "b", "B", redcap_data_b, redcap_metadata_b
) %>%
  as_supertbl()

test_that("write_redcap_xlsx without labels works", {
  withr::with_tempdir({
    write_redcap_xlsx(supertbl,
      file = "supertbl_wb.xlsx",
      include_metadata_sheet = FALSE,
      include_toc_sheet = FALSE,
      recode_logical = FALSE
    )
    sheet_1 <- openxlsx2::read_xlsx(file = "supertbl_wb.xlsx", sheet = 1, start_row = 1)
    # For some reason, read_xlsx resets row names and starts at 2, likely due
    # to reading the column names as a row
    rownames(sheet_1) <- seq_len(nrow(sheet_1))

    sheet_2 <- openxlsx2::read_xlsx(file = "supertbl_wb.xlsx", sheet = 2)
    rownames(sheet_2) <- seq_len(nrow(sheet_2))

    # Ignore attr applied by openxlsx2 read_xlsx
    expect_equal(tibble::tibble(sheet_1), redcap_data_a, ignore_attr = TRUE)
    expect_equal(tibble::tibble(sheet_2), redcap_data_b, ignore_attr = TRUE)
  })
})


test_that("write_redcap_xlsx with labels works", {
  labelled_supertbl <- make_labelled(supertbl)

  labelled_sheet_1 <- tibble::tribble(
    ~"Record ID", ~"Label A",
    "record_id", "col_a",
    "1", "A"
  )

  labelled_sheet_2 <- tibble::tribble(
    ~"Record ID", ~"Label B",
    "record_id", "col_b",
    "1", "B"
  )

  withr::with_tempdir({
    write_redcap_xlsx(labelled_supertbl,
      add_labelled_column_headers = TRUE,
      file = "labelled_supertbl_wb.xlsx",
      include_toc_sheet = FALSE,
      include_metadata_sheet = FALSE,
      recode_logical = FALSE
    )
    sheet_1 <- openxlsx2::read_xlsx(file = "labelled_supertbl_wb.xlsx", sheet = 1)
    sheet_2 <- openxlsx2::read_xlsx(file = "labelled_supertbl_wb.xlsx", sheet = 2)

    expect_equal(tibble::tibble(sheet_1), labelled_sheet_1, ignore_attr = TRUE)
    expect_equal(tibble::tibble(sheet_2), labelled_sheet_2, ignore_attr = TRUE)
  })
})

test_that("write_redcap_xlsx has expected supertibble and metadata outputs", {
  # tribble for readability
  expected_supertibble <- tibble::tribble(
    ~redcap_form_name, ~redcap_form_label, ~`Sheet #`,
    "a", "A", 1,
    "b", "B", 2,
    "REDCap Metadata", NA, 3
  ) %>%
    as.data.frame()

  expected_meta <- tibble::tribble(
    ~redcap_form_name, ~redcap_form_label, ~field_name, ~field_label, ~field_type,
    NA, NA, "record_id", "Record ID", "text",
    "a", "A", "col_a", "Label A", "text",
    "b", "B", "col_b", "Label B", "text"
  ) %>%
    as.data.frame()

  withr::with_tempdir({
    write_redcap_xlsx(supertbl,
      add_labelled_column_headers = FALSE,
      file = "default_supertbl_wb.xlsx",
      include_toc_sheet = TRUE,
      include_metadata_sheet = TRUE,
      recode_logical = FALSE
    )
    sheet_1 <- openxlsx2::read_xlsx(file = "default_supertbl_wb.xlsx", sheet = 1)
    # Address rowname discrepancies
    rownames(sheet_1) <- seq_len(nrow(sheet_1))
    sheet_4 <- openxlsx2::read_xlsx(file = "default_supertbl_wb.xlsx", sheet = 4)
    rownames(sheet_4) <- seq_len(nrow(sheet_4))

    expect_equal(sheet_1, expected_supertibble, ignore_attr = TRUE)
    expect_equal(sheet_4, expected_meta, ignore_attr = TRUE)
  })

  expected_supertibble_labels <- c(
    "REDCap Instrument Name",
    "REDCap Instrument Description",
    "Sheet #"
  )

  expected_meta_labels <- c(
    "REDCap Instrument Name",
    "REDCap Instrument Description",
    "Variable / Field Name",
    "Field Label",
    "Field Type"
  )

  withr::with_tempdir({
    write_redcap_xlsx(supertbl %>% make_labelled(),
      add_labelled_column_headers = TRUE,
      file = "default_labelled_supertbl_wb.xlsx",
      include_toc_sheet = TRUE,
      include_metadata_sheet = TRUE,
      recode_logical = FALSE
    )
    sheet_1 <- openxlsx2::read_xlsx(
      file = "default_labelled_supertbl_wb.xlsx",
      sheet = 1
    )
    sheet_4 <- openxlsx2::read_xlsx(
      file = "default_labelled_supertbl_wb.xlsx",
      sheet = 4
    )

    expect_setequal(names(sheet_1), expected_supertibble_labels)
    expect_setequal(names(sheet_4), expected_meta_labels)
  })
})

test_that("write_redcap_xlsx checks work", {
  withr::with_tempdir({
    supertbl %>%
      write_redcap_xlsx(
        add_labelled_column_headers = TRUE,
        file = "temp.xlsx",
        recode_logical = FALSE
      ) %>%
      expect_error()

    supertbl %>%
      make_labelled() %>%
      write_redcap_xlsx(
        add_labelled_column_headers = TRUE, file =
          "temp.xlsx",
        recode_logical = FALSE
      ) %>%
      expect_no_error()
  })
})

test_that("bind_supertbl_metadata works", {
  supertbl_meta <- bind_supertbl_metadata(supertbl)
  expected_meta <- tibble::tribble(
    ~redcap_form_name, ~redcap_form_label, ~field_name, ~field_label, ~field_type,
    NA, NA, "record_id", "Record ID", "text",
    "a", "A", "col_a", "Label A", "text",
    "b", "B", "col_b", "Label B", "text"
  )

  expect_equal(supertbl_meta, expected_meta)
})

test_that("supertbl_recode works", {
  # Set up testable yesno fields and metadata
  redcap_data_c <- tibble::tribble(
    ~record_id, ~yesno, ~checkbox,
    1,          TRUE,   TRUE,
    2,          FALSE,  FALSE,
    3,          NA,     NA
  )

  redcap_metadata_c <- tibble::tribble(
    ~field_name, ~field_type, ~field_label,
    "record_id", "text", "Record ID",
    "yesno", "yesno", "YesNo",
    "checkbox", "checkbox", "Checkbox"
  )

  supertbl_recoded <- tibble::tribble(
    ~redcap_form_name, ~redcap_form_label, ~redcap_data, ~redcap_metadata,
    "c", "C", redcap_data_c, redcap_metadata_c
  ) %>%
    as_supertbl() %>%
    make_labelled()

  # Pass through testing function
  supertbl_recoded_meta <- bind_supertbl_metadata(supertbl_recoded)

  out <- supertbl_recode(supertbl_recoded,
    supertbl_recoded_meta,
    add_labelled_column_headers = TRUE
  )

  # Set up expectations
  expected_out <- tibble::tribble(
    ~record_id, ~yesno, ~checkbox,
    1,          "yes",  "Checked",
    2,          "no",   "Unchecked",
    3,          NA,     NA
  )

  # Add labels to check for preservation
  labelled::var_label(expected_out) <- c("Record ID", "YesNo", "Checkbox")

  expect_equal(out[[1]], expected_out)
})

test_that("check_labelled works", {
  labelled_supertbl <- supertbl %>%
    make_labelled()

  # Check possibilities for unlabelled supertbl
  expect_false(check_labelled(supertbl, add_labelled_column_headers = NULL))
  expect_error(check_labelled(supertbl, add_labelled_column_headers = TRUE), class = "missing_labelled_labels")
  expect_false(check_labelled(supertbl, add_labelled_column_headers = FALSE))

  # Check possibilities for labelled supertbl
  expect_true(check_labelled(labelled_supertbl, add_labelled_column_headers = NULL))
  expect_true(check_labelled(labelled_supertbl, add_labelled_column_headers = TRUE))
  expect_false(check_labelled(labelled_supertbl, add_labelled_column_headers = FALSE))
})

test_that("key argument checks work", {
  # labelled arg
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", add_labelled_column_headers = "char"),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", add_labelled_column_headers = 1),
    class = "check_logical"
  )

  # use_labels_for_sheet_names arg
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", use_labels_for_sheet_names = NULL),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", use_labels_for_sheet_names = "char"),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", use_labels_for_sheet_names = 1),
    class = "check_logical"
  )
  # include_toc_sheet arg
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", include_toc_sheet = NULL),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", include_toc_sheet = "char"),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", include_toc_sheet = 1),
    class = "check_logical"
  )

  # include_metadata_sheet arg
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", include_metadata_sheet = NULL),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", include_metadata_sheet = "char"),
    class = "check_logical"
  )
  expect_error(
    write_redcap_xlsx(supertbl, file = "temp.xlsx", include_metadata_sheet = 1),
    class = "check_logical"
  )

  # recode_logical arg
  expect_error(write_redcap_xlsx(supertbl, file = "temp.xlsx", recode_logical = NULL), class = "check_logical")
  expect_error(write_redcap_xlsx(supertbl, file = "temp.xlsx", recode_logical = "char"), class = "check_logical")
  expect_error(write_redcap_xlsx(supertbl, file = "temp.xlsx", recode_logical = 1), class = "check_logical")

  # file arg
  withr::with_tempdir({
    expect_warning(write_redcap_xlsx(supertbl, file = "temp.docx"),
      class = "invalid_file_extension"
    )
  })
  withr::with_tempdir({
    expect_warning(write_redcap_xlsx(supertbl, file = "temp"),
      class = "invalid_file_extension"
    )
  })
  expect_error(write_redcap_xlsx(supertbl, file = TRUE), class = "check_character")
  expect_error(write_redcap_xlsx(supertbl, file = NULL), class = "check_character")
})

test_that("bind_supertbl_metadata works", {
  # Create a supertbl metadata table representing in the output and check all
  # expected elements are present
  expected_meta <- tibble::tribble(
    ~redcap_form_name, ~redcap_form_label, ~field_name, ~field_label, ~field_type,
    NA, NA, "record_id", "Record ID", "text",
    "a", "A", "col_a", "Label A", "text",
    "b", "B", "col_b", "Label B", "text"
  )

  supertbl_meta <- supertbl %>%
    bind_supertbl_metadata()

  expect_equal(expected_meta, supertbl_meta)
  expect_true(all(names(expected_meta) %in% names(supertbl_meta)))
})



test_that("Combining skimr, labelled, and xlsx returns expected snapshot", {
  skip_on_cran()
  skip_on_ci()
  out <-
    read_redcap(Sys.getenv("REDCAP_URI"), Sys.getenv("REDCAPTIDIER_CLASSIC_API")) %>%
    # Suppress expected warnings from the REDCapTidieR Classic database.
    # Warnings here are meant to validate checks in other tests.
    suppressWarnings(classes = c(
      "field_missing_categories",
      "empty_parse_warning",
      "duplicate_labels"
    ))

  withr::with_tempdir({
    wb_obj <- out %>%
      make_labelled() %>%
      add_skimr_metadata() %>%
      write_redcap_xlsx(file = "temp.xlsx")
  })

  # Extract all data from wb_obj per sheet, assign to a dataframe
  wb_obj_data <- purrr::map(wb_obj$tables$tab_sheet, ~ openxlsx2::wb_to_df(wb_obj, sheet = .x))

  # Select additional wb elements of interest, combine with wb_obj_data
  wb_list <- list(
    wb_obj_data,
    wb_obj$tables,
    wb_obj$workbook,
    wb_obj$workbook.xml.rels,
    wb_obj$sheetOrder,
    wb_obj$sheet_names
  )

  expect_snapshot(wb_list, cran = FALSE) # Not to be checked on CRAN
})