tests/testthat/test-meta.R

In Tplyr: A Traceability Focused Grammar of Clinical Data Summary

load(test_path('adae.Rdata'))
load(test_path('adsl.Rdata'))
load(test_path('adlb.Rdata'))

adae <- adae %>%
  filter(AEBODSYS %in% c("NERVOUS SYSTEM DISORDERS", "SKIN AND SUBCUTANEOUS TISSUE DISORDERS",
                         "PSYCHIATRIC DISORDERS" ))

# Alter some reference indicators for shift
adlb[c(5, 10, 15, 20, 25, 30), 'ANRIND'] <- "H"
adlb[c(5, 10, 15, 20, 25, 30), 'BNRIND'] <- "L"

# Insert a missing value
adsl$ETHNIC[1] <- NA_character_

# Define a function to flip factors to characters
fct2chr <- function(.data) {
  .data %>%
    mutate(
      across(where(is.factor), ~as.character(.x))
    )
}

# Table to test out totals, missings, table where, cols, by, unnested
# basic counts, and descriptive stats
t1 <- tplyr_table(adsl, TRT01A, where = SAFFL == "Y", cols=SEX) %>%
  add_treat_grps(
    Treated = c("Xanomeline High Dose", "Xanomeline Low Dose")
  ) %>%
  # Create a total group column
  add_total_group() %>%
  # Add a count layer for SEX
  add_layer(
    group_count(ETHNIC, by = RACE) %>%
      set_denoms_by(TRT01A) %>%
      # Make a total row
      add_total_row(fmt=f_str("xx",n), count_missings=FALSE, sort_value=-Inf) %>%
      # Change the total row label
      set_total_row_label("n") %>%
      # Add a missing count row, which is made up of any NA values
      set_missing_count(f_str("xx", n), denom_ignore=TRUE, Missing = NA, Empty = "Blah")
  ) %>%
  # Add a descriptive statistics layer for AGE
  add_layer(
    group_desc(AGE, by = RACE)
  )

dat1 <- t1 %>%
  build(metadata=TRUE)

# Table to test out character unnested, and nested counts, layer where
t2 <- tplyr_table(adae, TRTA) %>%
  add_layer(
    group_count("Text label", where = AESEV == "MODERATE") %>%
      add_risk_diff(
        c("Xanomeline High Dose", "Placebo")
      )
  ) %>%
  add_layer(
    group_count(vars(AEBODSYS, AEDECOD))
  )

dat2 <- suppressWarnings(t2 %>% build(metadata=TRUE))

# Table to test out character outer for count layers
t3 <- tplyr_table(adsl, TRT01A) %>%
  add_layer(
    group_count(vars("Outer string", RACE))
  )

dat3 <- t3 %>%
  build(metadata=TRUE)

# Table for testing of Shift layers
t4 <- tplyr_table(adlb, TRTA, where = AVISIT != "") %>%
  add_layer(
    group_shift(vars(row = BNRIND, column=ANRIND), by=AVISIT)
  )

dat4 <- t4 %>%
  build(metadata=TRUE)

test_that("Metadata creation errors generate properly", {
  m <- tplyr_meta()

  # Not providing metadata object
  expect_snapshot_error(add_variables(mtcars, quos(a)))
  expect_snapshot_error(add_filters(mtcars, quos(a==1)))
  expect_snapshot_error(add_anti_join(mtcars, m, quos(a==1)))
  expect_snapshot_error(add_anti_join(m, mtcars, quos(a==1)))

  # Didn't provide filter
  expect_snapshot_error(tplyr_meta(quos(a), 'x'))
  expect_snapshot_error(add_filters(m, 'x'))

  # Didn't provide names
  expect_snapshot_error(tplyr_meta('x'))
  expect_snapshot_error(add_variables(m, 'x'))
  expect_snapshot_error(add_anti_join(m, m, 'x'))

})

test_that("Exported metadata function construct metadata properly", {
  m <- tplyr_meta(quos(a, b, c), quos(a==1, b==2, c==3))

  expect_equal(m$names, quos(a, b, c))
  expect_equal(m$filters, quos(a==1, b==2, c==3))

  m <- add_variables(m, quos(x))
  m <- add_filters(m, quos(x=="a"))
  m2 <- add_anti_join(m, m, quos(y))

  expect_equal(m$names, quos(a, b, c, x))
  expect_equal(m$filters, quos(a==1, b==2, c==3, x=="a"))
  expect_equal(m2$anti_join$join_meta, m)
  expect_equal(m2$anti_join$on, quos(y))
})

test_that("Descriptive Statistics metadata backend assembles correctly", {

  # Standard treatment group
  m1 <- get_meta_subset(t1, 'd7_2', 'var1_Placebo_M')
  m1_comp <- t1$built_target %>%
    filter(
      RACE == "BLACK OR AFRICAN AMERICAN",
      SEX == "M",
      SAFFL == "Y",
      TRT01A == "Placebo"
    ) %>%
    select(USUBJID, TRT01A, RACE, SEX, SAFFL, AGE) %>%
    fct2chr()

  expect_equal(m1, m1_comp, ignore_attr=TRUE)

  # Total group
  m2 <- get_meta_subset(t1, 'd7_2', 'var1_Total_F')
  m2_comp <- t1$built_target %>%
    filter(
      RACE == "BLACK OR AFRICAN AMERICAN",
      SEX == "F",
      SAFFL == "Y",
      TRT01A %in% c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")
    ) %>%
    select(USUBJID, TRT01A, RACE, SEX, SAFFL, AGE) %>%
    fct2chr()

  expect_equal(m2, m2_comp, ignore_attr=TRUE)

  # Treated group
  m3 <- get_meta_subset(t1, 'd7_2', 'var1_Treated_F')
  m3_comp <- t1$built_target %>%
    filter(
      RACE == "BLACK OR AFRICAN AMERICAN",
      SEX == "F",
      SAFFL == "Y",
      TRT01A %in% c("Xanomeline High Dose", "Xanomeline Low Dose")
    ) %>%
    select(USUBJID, TRT01A, RACE, SEX, SAFFL, AGE) %>%
    fct2chr()

  expect_equal(m3, m3_comp, ignore_attr=TRUE)
})

test_that("Count Layer metadata backend assembles correctly", {

  # Here use demographics t1
  # Standard treatment, normal row count
  m1 <- get_meta_subset(t1, 'c6_1', 'var1_Placebo_M')
  m1_comp <- t1$built_target %>%
    filter(
      RACE == "BLACK OR AFRICAN AMERICAN",
      SEX == "M",
      SAFFL == "Y",
      TRT01A == "Placebo",
      ETHNIC == "NOT HISPANIC OR LATINO"
    ) %>%
    select(USUBJID, TRT01A, RACE, SEX, SAFFL, ETHNIC) %>%
    fct2chr()

  expect_equal(m1, m1_comp, ignore_attr=TRUE)

  # Total group, missing row
  m2 <- get_meta_subset(t1, 'c11_1', 'var1_Total_F')
  m2_comp <- t1$built_target %>%
    filter(
      RACE == "WHITE",
      SEX == "F",
      SAFFL == "Y",
      TRT01A %in% c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose"),
      is.na(ETHNIC)
    ) %>%
    select(USUBJID, TRT01A, RACE, SEX, SAFFL, ETHNIC) %>%
    fct2chr()

  expect_equal(m2, m2_comp, ignore_attr=TRUE)

  # Treated group, total row
  m3 <- get_meta_subset(t1, 'c13_1', 'var1_Treated_F')
  m3_comp <- t1$built_target %>%
    filter(
      SEX == "F",
      SAFFL == "Y",
      TRT01A %in% c("Xanomeline High Dose", "Xanomeline Low Dose")
    ) %>%
    select(USUBJID, TRT01A, SEX, SAFFL, ETHNIC, RACE) %>%
    fct2chr()

  expect_equal(m3, m3_comp, ignore_attr=TRUE)

  # Now using AE table t2
  # Unnested character target
  m4 <- get_meta_subset(t2, "c1_1", "var1_Xanomeline Low Dose")
  m4_comp <- t2$built_target %>%
    filter(
      AESEV == "MODERATE",
      TRTA == "Xanomeline Low Dose"
    ) %>%
    select(USUBJID, TRTA, AESEV) %>%
    fct2chr()

  expect_equal(m4, m4_comp, ignore_attr=TRUE)

  # Outer layer
  m5 <- get_meta_subset(t2, "c1_2", "var1_Xanomeline High Dose")
  m5_comp <- t2$built_target %>%
    filter(
      TRTA == "Xanomeline High Dose",
      AEBODSYS == "NERVOUS SYSTEM DISORDERS"
    ) %>%
    select(USUBJID, TRTA, AEDECOD, AEBODSYS) %>%
    fct2chr()

  expect_equal(m5, m5_comp, ignore_attr=TRUE)

  # Inner layer
  m6 <- get_meta_subset(t2, 'c6_2', "var1_Xanomeline Low Dose")
  m6_comp <- t2$built_target %>%
    filter(
      TRTA == "Xanomeline Low Dose",
      AEBODSYS == "NERVOUS SYSTEM DISORDERS",
      AEDECOD == "DIZZINESS"
    ) %>%
    select(USUBJID, TRTA, AEBODSYS, AEDECOD) %>%
    fct2chr()

  expect_equal(m6, m6_comp, ignore_attr=TRUE)

  # Risk difference
  m7 <- get_meta_subset(t2, 'c1_1', 'rdiff_Xanomeline High Dose_Placebo')
  m7_comp <- t2$built_target %>%
    filter(
      AESEV == "MODERATE",
      TRTA %in% c("Xanomeline High Dose", "Placebo")
    ) %>%
    select(USUBJID, TRTA, AESEV) %>%
    fct2chr()

  expect_equal(m4, m4_comp, ignore_attr=TRUE)


  # Character outer string
  m8 <- get_meta_subset(t3, 'c1_1', 'var1_Placebo')
  m8_comp <- t3$built_target %>%
    filter(
      TRT01A == "Placebo"
    ) %>%
    select(USUBJID, TRT01A, RACE) %>%
    fct2chr()

  expect_equal(m8, m8_comp, ignore_attr=TRUE)

  m9 <- get_meta_subset(t3, 'c3_1', 'var1_Placebo')
  m9_comp <- t3$built_target %>%
    filter(
      TRT01A == "Placebo",
      RACE == "BLACK OR AFRICAN AMERICAN"
    ) %>%
    select(USUBJID, TRT01A, RACE) %>%
    fct2chr()

  expect_equal(m9, m9_comp, ignore_attr=TRUE)

})

test_that("Shift Layer metadata backend assembles correctly", {
  m1 <- get_meta_subset(t4, 's3_1', 'var1_Placebo_H')
  m1_comp <- t4$built_target %>%
    filter(
      BNRIND == "L",
      ANRIND == "H",
      AVISIT == "End of Treatment",
      TRTA == "Placebo"
    ) %>%
    select(USUBJID, TRTA, AVISIT, ANRIND, BNRIND) %>%
    fct2chr()

  expect_equal(m1, m1_comp, ignore_attr=TRUE)
})

test_that("metadata queried without Tplyr table queries effectively", {
  # Pull out the dataframes directly
  meta <- t1$metadata
  dat <- t1$target

  m1 <- get_meta_subset(meta, 'd7_2', 'var1_Placebo_M', target = dat)

  m1_comp <- t1$built_target %>%
    filter(
      RACE == "BLACK OR AFRICAN AMERICAN",
      SEX == "M",
      SAFFL == "Y",
      TRT01A == "Placebo",
      ETHNIC == "NOT HISPANIC OR LATINO"
    ) %>%
    select(USUBJID, TRT01A, RACE, SEX, SAFFL, AGE) %>%
    fct2chr()

  expect_equal(m1, m1_comp, ignore_attr=TRUE)
})

t <- tplyr_table(mtcars, gear) %>%
  add_layer(
    group_desc(wt)
  )

test_that("Metadata extraction and extension error properly", {

  expect_snapshot_error(get_metadata(mtcars))

  expect_snapshot_error(get_metadata(t))

  dat <- t %>% build(metadata=TRUE)

  m <- tibble(
    var1_3 = list(tplyr_meta())
  )

  expect_snapshot_error(append_metadata(t, m))

  m['row_id'] <- c("d1_1")
  expect_snapshot_error(append_metadata(t, m))

})

test_that("Metadata extraction and extension work properly", {

  m <- tibble(
    row_id = 'x1_1',
    var1_3 = list(tplyr_meta())
  )

  t <- append_metadata(t, m)
  expect_snapshot(as.data.frame(get_metadata(t)))

})

test_that("Metadata print method is accurate", {
  x <- tplyr_meta(quos(a, b, c), quos(a==1, b==2, c==3, x=="a"))
  expect_snapshot(print(x))
})


test_that("Anti-join extraction works properly", {

  # This is purposefully a convoluted warning that's unrealistic, hence the
  # warning that's generating.
  expect_snapshot_warning({
    t <- tplyr_table(tplyr_adsl, TRT01A, cols = ETHNIC) %>%
      add_layer(
        group_count(RACE, by = SEX) %>%
          set_distinct_by(USUBJID) %>%
          add_missing_subjects_row()
      )
  })

  x <- build(t, metadata=TRUE)

  # Check that the object looks right
  res <- get_meta_result(t, 'c7_1', 'var1_Placebo_HISPANIC OR LATINO')

  expect_equal(unname(map_chr(res$names, as_label)), c("TRT01A", "SEX", "ETHNIC", "RACE"))
  expect_equal(
    unname(map_chr(res$filters, as_label)),
    c("TRT01A == c(\"Placebo\")", "SEX == c(\"F\")", "ETHNIC == c(\"HISPANIC OR LATINO\")",
      "TRUE", "TRUE")
    )
  expect_equal(unname(map_chr(res$anti_join$join_meta$names, as_label)), c("TRT01A", "ETHNIC"))
  expect_equal(
    unname(map_chr(res$anti_join$join_meta$filters, as_label)),
    c("TRT01A == c(\"Placebo\")", "ETHNIC == c(\"HISPANIC OR LATINO\")", "TRUE", "TRUE")
  )
  expect_equal(as_label(res$anti_join$on[[1]]), "USUBJID")

  # Variables needed for the merge aren't there
  expect_snapshot_error(get_meta_subset(t, 'c7_1', 'var1_Placebo_HISPANIC OR LATINO', add_cols = quos(SITEID)))


  sbst <- get_meta_subset(t, 'c7_1', 'var1_Placebo_HISPANIC OR LATINO')


  cmp <- tplyr_adsl %>% filter(
      USUBJID == "01-701-1023"
    )

  # The counted subjects will include female, so this subject would have to be male
  # Again - this is a weird example that wouldn't be used in practice, but this is the
  # row variable
  expect_true(cmp$SEX == "M")
  # Since this is column, these would both match the metadata
  expect_true(cmp$TRT01A == "Placebo")
  expect_true(cmp$ETHNIC == "HISPANIC OR LATINO")

  # and then selecting out the columns these should match
  expect_equal(
    sbst,
    cmp %>%
      select(USUBJID, TRT01A, ETHNIC)
  )

  # Now for a real example, but also test for nested counts
  t <- tplyr_table(tplyr_adae, TRTA) %>%
    set_pop_data(tplyr_adsl) %>%
    set_pop_treat_var(TRT01A) %>%
    add_layer(
      group_count(vars(AEBODSYS, AEDECOD)) %>%
        set_distinct_by(USUBJID) %>%
        add_missing_subjects_row(f_str("xx (XX.x%)", distinct_n, distinct_pct), sort_value = Inf)
    )

  x <- build(t, metadata=TRUE)

  sbst <- get_meta_subset(t, 'c23_1', 'var1_Placebo')

  # If you manually check out x, the count here is 65
  expect_equal(nrow(sbst), 65)
  expect_equal(unique(sbst$TRT01A), "Placebo")

})

test_that("Tplyr meta print method works as expected", {
  meta <- tplyr_meta(
    names = quos(TRTP, EFFFL, ITTFL, ANL01FL, SITEGR1, AVISIT, AVISITN, PARAMCD, AVAL, BASE, CHG),
    filters = quos(EFFFL == "Y", ITTFL == "Y", PARAMCD == "ACTOT", ANL01FL == "Y", AVISITN == 24)
  )

  meta2 <- meta %>%
    add_anti_join(
      join_meta = tplyr_meta(
        names = quos(TRT01P, EFFFL, ITTFL, SITEGR1),
        filters = quos(EFFFL == "Y", ITTFL == "Y")
      ),
      on = quos(USUBJID)
    )

  expect_snapshot(print(meta2))
})