tests/testthat/test-decode_column.R

In artoo: Lossless CDISC-Native Input and Output for Clinical Datasets

# decode_column(): single-variable codelist translation — the
# metatools::create_var_from_codelist() shape driven by the artoo_spec.
# Shares .map_codelist_values() with apply_spec()'s decode step, so the
# policies (no_match, trim, ignore_case) behave identically.

demo_adam_spec <- function() {
  artoo_spec(
    cdisc_adam_datasets,
    cdisc_adam_variables,
    codelists = cdisc_codelists
  )
}

demo_sdtm_spec <- function() {
  artoo_spec(
    cdisc_sdtm_datasets,
    cdisc_sdtm_variables,
    codelists = cdisc_codelists
  )
}

# Spec extended with a numeric coded variable (the RACEN pattern): SEXN is
# integer, owning a codelist whose terms are codes and decodes are SEX values.
sexn_spec <- function() {
  vars <- rbind(
    cdisc_sdtm_variables,
    data.frame(
      dataset = "DM",
      variable = "SEXN",
      label = "Sex (N)",
      data_type = "integer",
      length = 8L,
      order = NA_integer_,
      codelist_id = "SEXN",
      stringsAsFactors = FALSE
    )
  )
  cls <- rbind(
    cdisc_codelists,
    data.frame(
      codelist_id = "SEXN",
      term = c("1", "2"),
      decode = c("F", "M"),
      order = 1:2,
      stringsAsFactors = FALSE
    )
  )
  artoo_spec(cdisc_sdtm_datasets, vars, codelists = cls)
}

test_that("decode_column decodes into a new column, source untouched", {
  out <- decode_column(
    cdisc_dm,
    demo_sdtm_spec(),
    "DM",
    from = "SEX",
    to = "SEXDECD"
  )
  expect_identical(out$SEX, cdisc_dm$SEX)
  expect_setequal(unique(out$SEXDECD), c("Female", "Male"))
  # New column appends; everything else is unchanged.
  expect_identical(names(out), c(names(cdisc_dm), "SEXDECD"))
})

test_that("decode_column translates in place by default (to = from)", {
  out <- decode_column(cdisc_dm, demo_sdtm_spec(), "DM", from = "SEX")
  expect_setequal(unique(out$SEX), c("Female", "Male"))
})

test_that("decode_column derives a coded numeric from its decode (RACEN pattern)", {
  out <- decode_column(
    cdisc_dm,
    sexn_spec(),
    "DM",
    from = "SEX",
    to = "SEXN",
    direction = "to_code"
  )
  # Spec dataType integer -> the result is integer, not character.
  expect_type(out$SEXN, "integer")
  expect_identical(out$SEXN[out$SEX == "F"][1], 1L)
  expect_identical(out$SEXN[out$SEX == "M"][1], 2L)
  # And the spec label rides along.
  expect_identical(attr(out$SEXN, "label"), "Sex (N)")
})

test_that("the destination's codelist wins over the source's", {
  # SEX references C66731, SEXN references SEXN; to = SEXN must map through
  # SEXN's pairs (F -> 1), not C66731's (F -> Female).
  out <- decode_column(
    cdisc_dm,
    sexn_spec(),
    "DM",
    from = "SEX",
    to = "SEXN",
    direction = "to_code"
  )
  expect_true(all(out$SEXN %in% c(1L, 2L)))
})

test_that("decode_column chains two hops when from and to codelists share no values", {
  # SEXN's decodes are the LONG decodes ("Female"/"Male"), not SEX's
  # submission values ("F"/"M"): the single hop through the destination's
  # codelist matches nothing and must hit the no_match policy, and the
  # documented two-hop chain (decode via from's list, then to_code via
  # to's) is the way through.
  vars <- rbind(
    cdisc_sdtm_variables,
    data.frame(
      dataset = "DM",
      variable = "SEXN",
      label = "Sex (N)",
      data_type = "integer",
      length = 8L,
      order = NA_integer_,
      codelist_id = "SEXN",
      stringsAsFactors = FALSE
    )
  )
  cls <- rbind(
    cdisc_codelists,
    data.frame(
      codelist_id = "SEXN",
      term = c("1", "2"),
      decode = c("Female", "Male"),
      order = 1:2,
      stringsAsFactors = FALSE
    )
  )
  spec <- artoo_spec(cdisc_sdtm_datasets, vars, codelists = cls)
  expect_error(
    decode_column(
      cdisc_dm,
      spec,
      "DM",
      from = "SEX",
      to = "SEXN",
      direction = "to_code"
    ),
    class = "artoo_error_codelist"
  )
  expect_snapshot(
    error = TRUE,
    decode_column(
      cdisc_dm,
      spec,
      "DM",
      from = "SEX",
      to = "SEXN",
      direction = "to_code"
    )
  )
  out <- cdisc_dm |>
    decode_column(spec, "DM", from = "SEX", to = "SEXDECD") |>
    decode_column(
      spec,
      "DM",
      from = "SEXDECD",
      to = "SEXN",
      direction = "to_code"
    )
  expect_type(out$SEXN, "integer")
  expect_identical(out$SEXN[out$SEX == "F"][1], 1L)
  expect_identical(out$SEXN[out$SEX == "M"][1], 2L)
  expect_identical(attr(out$SEXN, "label"), "Sex (N)")
})

test_that("decode_column honors the no_match policy", {
  raw <- cdisc_dm
  raw$SEX[1] <- "X"
  spec <- demo_sdtm_spec()
  expect_error(
    decode_column(raw, spec, "DM", from = "SEX", to = "SEXDECD"),
    class = "artoo_error_codelist"
  )
  kept <- decode_column(
    raw,
    spec,
    "DM",
    from = "SEX",
    to = "SEXDECD",
    no_match = "keep"
  )
  expect_identical(kept$SEXDECD[1], "X")
  nad <- decode_column(
    raw,
    spec,
    "DM",
    from = "SEX",
    to = "SEXDECD",
    no_match = "na"
  )
  expect_true(is.na(nad$SEXDECD[1]))
})

test_that("decode_column soft-matches after trim and reports the variant", {
  raw <- cdisc_dm
  raw$SEX[1] <- "F "
  expect_warning(
    out <- decode_column(
      raw,
      demo_sdtm_spec(),
      "DM",
      from = "SEX",
      to = "SEXDECD"
    ),
    class = "artoo_warning_codelist"
  )
  expect_identical(out$SEXDECD[1], "Female")
})

test_that("decode_column validates its inputs loudly", {
  spec <- demo_sdtm_spec()
  expect_error(
    decode_column(1, spec, "DM", from = "SEX"),
    class = "artoo_error_input"
  )
  expect_error(
    decode_column(cdisc_dm, spec, "DM", from = "NOPE"),
    class = "artoo_error_input"
  )
  expect_error(
    decode_column(cdisc_dm, spec, "DM", from = "SEX", to = c("A", "B")),
    class = "artoo_error_input"
  )
  # No codelist on either end is an explicit error, not a silent no-op.
  expect_error(
    decode_column(cdisc_dm, spec, "DM", from = "USUBJID", to = "USUBJ2"),
    class = "artoo_error_codelist"
  )
  expect_snapshot(
    error = TRUE,
    decode_column(cdisc_dm, spec, "DM", from = "USUBJID", to = "USUBJ2")
  )
})

test_that("decode_column to_decode then to_code restores the codes", {
  spec <- demo_sdtm_spec()
  dec <- decode_column(cdisc_dm, spec, "DM", from = "SEX")
  back <- decode_column(dec, spec, "DM", from = "SEX", direction = "to_code")
  expect_identical(as.vector(back$SEX), as.vector(cdisc_dm$SEX))
})

test_that("decode_column warns when the spec dataType coercion introduces NA", {
  # Destination is integer but the codelist terms are not numeric: the
  # coercion cannot represent them and must say so, never silently.
  vars <- rbind(
    cdisc_sdtm_variables,
    data.frame(
      dataset = "DM",
      variable = "SEXN",
      label = "Sex (N)",
      data_type = "integer",
      length = 8L,
      order = NA_integer_,
      codelist_id = "SEXTXT",
      stringsAsFactors = FALSE
    )
  )
  cls <- rbind(
    cdisc_codelists,
    data.frame(
      codelist_id = "SEXTXT",
      term = c("MALE", "FEMALE"),
      decode = c("M", "F"),
      order = 1:2,
      stringsAsFactors = FALSE
    )
  )
  spec <- artoo_spec(cdisc_sdtm_datasets, vars, codelists = cls)
  expect_warning(
    out <- decode_column(
      cdisc_dm,
      spec,
      "DM",
      from = "SEX",
      to = "SEXN",
      direction = "to_code"
    ),
    class = "artoo_warning_coercion"
  )
  expect_true(all(is.na(out$SEXN)))
})