tests/testthat/test-call_derivation.R

In Roche-GSK/admiral: ADaM in R Asset Library

## Test 1: Test that call_derivation generates expected summary  ----
# ---- call_derivation Test 1:  Test that call_derivation generates expected summary ----
test_that("call_derivation Test 1:  Test that call_derivation generates expected summary", {
  input <- pharmaversesdtm::vs[sample(seq_len(nrow(pharmaversesdtm::vs)), 1000), ]

  expected_output <- input %>%
    derive_summary_records(
      dataset_add = input,
      by_vars = exprs(USUBJID, VSTESTCD),
      set_values_to = exprs(
        VSSTRESN = mean(VSSTRESN, na.rm = TRUE),
        DTYPE = "AVERAGE"
      ),
      filter_add = dplyr::n() >= 2L
    ) %>%
    derive_summary_records(
      dataset_add = input,
      by_vars = exprs(USUBJID, VSTESTCD),
      set_values_to = exprs(
        VSSTRESN = max(VSSTRESN, na.rm = TRUE),
        DTYPE = "MAXIMUM"
      ),
      filter_add = dplyr::n() >= 2L
    ) %>%
    derive_summary_records(
      dataset_add = input,
      by_vars = exprs(USUBJID, VSTESTCD),
      set_values_to = exprs(
        VSSTRESN = min(VSSTRESN, na.rm = TRUE),
        DTYPE = "MINIMUM"
      ),
      filter_add = dplyr::n() >= 2L
    )

  actual_output <- call_derivation(
    dataset = input,
    dataset_add = input,
    derivation = derive_summary_records,
    variable_params = list(
      params(
        set_values_to = exprs(
          VSSTRESN = mean(VSSTRESN, na.rm = TRUE),
          DTYPE = "AVERAGE"
        )
      ),
      params(
        set_values_to = exprs(
          VSSTRESN = max(VSSTRESN, na.rm = TRUE),
          DTYPE = "MAXIMUM"
        )
      ),
      params(
        set_values_to = exprs(
          VSSTRESN = min(VSSTRESN, na.rm = TRUE),
          DTYPE = "MINIMUM"
        )
      )
    ),
    by_vars = exprs(USUBJID, VSTESTCD),
    filter_add = dplyr::n() >= 2L
  )

  expect_dfs_equal(
    expected_output,
    actual_output,
    keys = c("USUBJID", "VSTESTCD", "VISIT", "DTYPE", "VSSEQ")
  )
})

## Test 2: Test that call_derivation generates expected imputation  ----
# ---- call_derivation Test 2: Test that call_derivation generates expected imputation ----
test_that("call_derivation Test 2: Test that call_derivation generates expected imputation", {
  input <- pharmaversesdtm::ae[sample(seq_len(nrow(pharmaversesdtm::ae)), 1000), ] %>%
    left_join(admiral_adsl, by = "USUBJID")

  expected_output <- input %>%
    derive_vars_dt(
      new_vars_prefix = "AST",
      dtc = AESTDTC,
      date_imputation = "first",
      min_dates = exprs(TRTSDT),
      max_dates = exprs(TRTEDT)
    ) %>%
    derive_vars_dt(
      new_vars_prefix = "AEN",
      dtc = AEENDTC,
      date_imputation = "last",
      min_dates = exprs(TRTSDT),
      max_dates = exprs(TRTEDT)
    )

  actual_output <- call_derivation(
    dataset = input,
    derivation = derive_vars_dt,
    variable_params = list(
      params(dtc = AESTDTC, date_imputation = "first", new_vars_prefix = "AST"),
      params(dtc = AEENDTC, date_imputation = "last", new_vars_prefix = "AEN")
    ),
    min_dates = exprs(TRTSDT),
    max_dates = exprs(TRTEDT)
  )

  expect_dfs_equal(expected_output, actual_output, keys = c("USUBJID", "AESEQ"))
})

## Test 3: Test that Error is thrown if ... has no arguments  ----
# ---- call_derivation Test 3: Test that Error is thrown if ... has no arguments ----
test_that("call_derivation Test 3: Test that Error is thrown if ... has no arguments", {
  input <- pharmaversesdtm::ae[sample(seq_len(nrow(pharmaversesdtm::ae)), 1000), ] %>%
    left_join(admiral_adsl, by = "USUBJID")

  expect_snapshot(
    call_derivation(
      dataset = input,
      derivation = derive_vars_dt,
      variable_params = list(
        params(dtc = AESTDTC, date_imputation = "first", new_vars_prefix = "AST"),
        params(dtc = AEENDTC, date_imputation = "last", new_vars_prefix = "AEN")
      )
    ),
    error = TRUE
  )
})

## Test 4: Error is thrown if ... arguments are not properly named ----
# ---- call_derivation Test 4: Error is thrown if ... arguments are not properly named ----
test_that("call_derivation Test 4: Error is thrown if ... arguments are not properly named", {
  input <- pharmaversesdtm::ae[sample(seq_len(nrow(pharmaversesdtm::ae)), 1000), ] %>%
    left_join(admiral_adsl, by = "USUBJID")

  expect_snapshot(
    call_derivation(
      dataset = input,
      derivation = derive_vars_dt,
      variable_params = list(
        params(dtc = AESTDTC, date_imputation = "first", new_vars_prefix = "AST"),
        params(dtc = AEENDTC, date_imputation = "last", new_vars_prefix = "AEN")
      ),
      XYZSDT,
      XYZEDT
    ),
    error = TRUE
  )
})

## Test 5: Error is thrown params is empty ----
# ---- call_derivation Test 5: Error is thrown params is empty ----
test_that("call_derivation Test 5: Error is thrown if params is empty", {
  input <- pharmaversesdtm::ae[sample(seq_len(nrow(pharmaversesdtm::ae)), 1000), ] %>%
    left_join(admiral_adsl, by = "USUBJID")

  expect_snapshot(
    call_derivation(
      dataset = input,
      derivation = derive_vars_dt,
      variable_params = list(
        params(),
        params()
      ),
      min_dates = exprs(TRTSDT),
      max_dates = exprs(TRTEDT)
    ),
    error = TRUE
  )
})

## Test 6: Error is thrown if passed params are not properly named ----
# ---- call_derivation Test 6: Error is thrown if passed params are not properly named ----
test_that("call_derivation Test 6: Error is thrown if passed params are not properly named", {
  input <- pharmaversesdtm::ae[sample(seq_len(nrow(pharmaversesdtm::ae)), 1000), ] %>%
    left_join(admiral_adsl, by = "USUBJID")

  expect_snapshot(
    call_derivation(
      dataset = input,
      derivation = derive_vars_dt,
      variable_params = list(
        params(XYZ),
        params(XYZ)
      ),
      min_dates = exprs(TRTSDT),
      max_dates = exprs(TRTEDT)
    ),
    error = TRUE
  )
})

## Test 7: Error is thrown if `...` arguments are not properly named ----
# ---- call_derivation Test 7: Error is thrown if `...` arguments are not properly named ----
test_that("call_derivation Test 7: Error is thrown if `...` arguments are not properly named", {
  input <- pharmaversesdtm::ae[sample(seq_len(nrow(pharmaversesdtm::ae)), 1000), ] %>%
    left_join(admiral_adsl, by = "USUBJID")

  expect_snapshot(
    call_derivation(
      dataset = input,
      derivation = derive_vars_dt,
      variable_params = list(
        params(dtc = AESTDTC, date_imputation = "first", new_vars_prefix = "AST"),
        params(dtc = AEENDTC, date_imputation = "last", new_vars_prefix = "AEN")
      ),
      XYZSDT,
      XYZEDT
    ),
    error = TRUE
  )
})

## Test 8: Error is thrown if duplicate parameters ----
# ---- call_derivation Test 8: Error is thrown if duplicate parameters ----
test_that("call_derivation Test 8: Error is thrown if duplicate parameters", {
  expect_snapshot(
    error = TRUE,
    params(dtc = VSDTC, dtc = VSDTC, new_vars_prefix = "A")
  )
})