tests/testthat/test-tbl_hierarchical.R

In gtsummary: Presentation-Ready Data Summary and Analytic Result Tables

skip_on_cran()

trial2 <- trial |>
  mutate(id = rep(1:50, length.out = nrow(trial)))

# tbl_hierarchical(data) ------------------------------------------------------------
test_that("tbl_hierarchical(data) works properly", {
  # creates table when data frame is passed
  expect_snapshot(tbl_hierarchical(data = trial2, variables = trt, denominator = trial2, id = id) |> as.data.frame())

  # errors thrown when bad data argument passed
  expect_snapshot(error = TRUE, tbl_hierarchical())
  expect_snapshot(error = TRUE, tbl_hierarchical(data = letters))
})

# tbl_hierarchical(by) ------------------------------------------------------------
test_that("tbl_hierarchical(by) works properly", {
  # creates table when by is passed
  expect_snapshot(tbl_hierarchical(data = trial2, variables = stage, by = trt, denominator = trial2, id = id) |> as.data.frame())

  # errors thrown when bad by argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(data = trial2, variables = stage, by = name, denominator = trial2, id = id)
  )
})

# tbl_hierarchical(id) ------------------------------------------------------------
test_that("tbl_hierarchical(id) works properly", {
  # errors thrown when bad id argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(data = trial2, variables = trt, denominator = trial2, id = 10)
  )
})

# tbl_hierarchical(denominator) ------------------------------------------------------------
test_that("tbl_hierarchical(denominator) works properly", {
  # errors thrown when bad denominator argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(data = trial2, variables = trt, denominator = "test")
  )
})

# tbl_hierarchical(include) ------------------------------------------------------------
test_that("tbl_hierarchical(include) works properly", {
  # creates table when include is passed
  expect_snapshot(
    tbl_hierarchical(data = trial2, variables = c(stage, grade), denominator = trial2, id = id, include = grade) |> as.data.frame()
  )
  expect_snapshot(
    tbl_hierarchical(data = trial2, variables = c(stage, grade), by = trt, denominator = trial2, id = id, include = NULL) |> as.data.frame()
  )

  # errors thrown when bad include argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(
      data = trial2, variables = c(stage, grade), denominator = trial2, id = id, include = name
    )
  )
})

# tbl_hierarchical(statistic) ------------------------------------------------------------
test_that("tbl_hierarchical(statistic) works properly", {
  # creates table when statistic is passed
  expect_snapshot(tbl_hierarchical(
    data = trial2, variables = c(stage, grade), denominator = trial2, id = id,
    statistic = "{n}, {N}, {p}"
  ) |> as.data.frame())

  # errors thrown when bad statistic argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(
      data = trial2, variables = c(stage, grade), denominator = trial2, id = id,
      statistic = list(stage = "{n}")
    )
  )
})

# tbl_hierarchical(overall_row) ------------------------------------------------------------
test_that("tbl_hierarchical(overall_row) works properly", {
  # creates table when overall_row is passed
  expect_snapshot(tbl_hierarchical(data = trial2, variables = trt, denominator = trial2, id = id, overall_row = TRUE) |> as.data.frame())

  # value are correct when by is passed
  expect_warning(expect_warning(
    res <-
      tbl_hierarchical(data = trial2, variables = trt, by = grade, denominator = trial2, id = id, overall_row = TRUE)
  ))
  expect_snapshot(res |> as.data.frame())
  expect_equal((res |> as.data.frame())[1, 1], "Total number of patients with any event")
  expect_equal(
    (res |> as.data.frame())[1, -1] |> as.character(),
    c("40 (58.8)", "38 (55.9)", "39 (60.9)")
  )

  # overall row labeling works
  expect_warning(expect_warning(
    res <-
      tbl_hierarchical(
        data = trial2, variables = trt, by = grade, denominator = trial2, id = id, overall_row = TRUE,
        label = list(overall = "Total patients")
      )
  ))
  expect_equal((res |> as.data.frame())[1, 1], "Total patients")

  # errors thrown when bad overall_row argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(data = trial2, variables = trt, denominator = trial2, id = id, overall_row = "test")
  )
})

# tbl_hierarchical(label) ------------------------------------------------------------
test_that("tbl_hierarchical(label) works properly", {
  # creates table when label is passed
  res <- tbl_hierarchical(
    data = trial2, variables = c(stage, grade), denominator = trial2, id = id,
    label = list(stage = "My Stage", grade = "My Grade")
  )
  expect_snapshot(res |> as.data.frame())
  expect_snapshot_value(res$table_styling$header$label[4])

  # errors thrown when bad label argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical(data = trial2, variables = c(stage, grade), denominator = trial2, id = id, label = "Stages")
  )
})

# tbl_hierarchical with ordered variables ------------------------------------------------------------
test_that("tbl_hierarchical works properly when last variable of hierarchy is ordered", {
  data <- cards::ADAE |>
    dplyr::filter(
      AESOC %in% unique(cards::ADAE$AESOC)[1:10],
      AETERM %in% unique(cards::ADAE$AETERM)[1:10]
    )

  # unordered variable
  res_uo <- tbl_hierarchical(
    data = data, variables = c(AESOC, AESEV), by = TRTA, id = USUBJID,
    denominator = cards::ADSL |> mutate(TRTA = ARM), include = AESEV
  )

  # ordered variable
  data$AESEV <- factor(data$AESEV, ordered = TRUE)

  res_o <- tbl_hierarchical(
    data = data, variables = c(AESOC, AESEV), by = TRTA, id = USUBJID,
    denominator = cards::ADSL |> mutate(TRTA = ARM), include = AESEV, label = list(AESEV = "Highest Severity")
  ) |> suppressMessages()
  expect_snapshot(res_o |> as.data.frame())

  # compare ordered and unordered results
  expect_true(res_uo$table_body$stat_1[9] > res_o$table_body$stat_1[10])

  # ordered variable, no by
  res <- tbl_hierarchical(
    data = data, variables = c(AESOC, AESEV),
    denominator = cards::ADSL |> mutate(TRTA = ARM), id = USUBJID
  ) |> suppressMessages()
  expect_snapshot(res |> as.data.frame())
})

# tbl_hierarchical_count(data) ------------------------------------------------------------
test_that("tbl_hierarchical_count(data) works properly", {
  # creates table when data frame is passed
  expect_snapshot(tbl_hierarchical_count(data = trial, variables = trt) |> as.data.frame())
  expect_snapshot(tbl_hierarchical_count(data = iris, variables = Species) |> as.data.frame())

  # errors thrown when bad data argument passed
  expect_snapshot(error = TRUE, tbl_hierarchical_count())
  expect_snapshot(error = TRUE, tbl_hierarchical_count(data = letters))
})

# tbl_hierarchical_count(by) ------------------------------------------------------------
test_that("tbl_hierarchical_count(by) works properly", {
  # creates table when by is passed
  expect_snapshot(tbl_hierarchical_count(data = trial, variables = stage, by = trt) |> as.data.frame())

  # errors thrown when bad by argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical_count(data = trial, variables = stage, by = name)
  )
})

# tbl_hierarchical_count(denominator) ------------------------------------------------------------
test_that("tbl_hierarchical_count(denominator) works properly", {
  # creates table when denominator is passed
  res <- tbl_hierarchical_count(data = trial, variables = trt, denominator = rbind(trial, trial))
  expect_snapshot(res |> as.data.frame())
  expect_equal(res$table_styling$header$modify_stat_N[1], nrow(trial) * 2)

  # errors thrown when bad denominator argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical_count(data = trial, variables = trt, denominator = "test")
  )
})

# tbl_hierarchical_count(include) ------------------------------------------------------------
test_that("tbl_hierarchical_count(include) works properly", {
  # creates table when include is passed
  expect_snapshot(
    tbl_hierarchical_count(data = trial, variables = c(stage, grade), include = grade) |> as.data.frame()
  )
  expect_snapshot(
    tbl_hierarchical_count(data = trial, variables = c(stage, grade), by = trt, include = NULL) |> as.data.frame()
  )

  # errors thrown when bad include argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical_count(data = trial, variables = c(stage, grade), include = name)
  )
})

# tbl_hierarchical_count(overall_row) ------------------------------------------------------------
test_that("tbl_hierarchical_count(overall_row) works properly", {
  # creates table when overall_row is passed
  expect_snapshot(tbl_hierarchical_count(data = trial, variables = trt, overall_row = TRUE) |> as.data.frame())

  # value are correct when by is passed
  res <- tbl_hierarchical_count(data = trial, variables = trt, by = grade, overall_row = TRUE)
  expect_snapshot(res |> as.data.frame())
  expect_equal((res |> as.data.frame())[1, 1], "Total number of events")
  expect_equal(
    (res |> as.data.frame())[1, -1] |> as.character(),
    (trial |> dplyr::group_by(grade) |> dplyr::summarise(n = dplyr::n()))$n |> as.character()
  )

  # overall row labeling works
  res <- tbl_hierarchical_count(
    data = trial, variables = trt, by = grade, overall_row = TRUE, label = list(overall = "Total rows")
  )
  expect_equal((res |> as.data.frame())[1, 1], "Total rows")

  # errors thrown when bad overall_row argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical_count(data = trial, variables = trt, overall_row = "test")
  )
})

# tbl_hierarchical_count(label) ------------------------------------------------------------
test_that("tbl_hierarchical_count(label) works properly", {
  # creates table when label is passed
  res <- tbl_hierarchical_count(
    data = trial, variables = c(stage, grade), label = list(stage = "My Stage", grade = "My Grade")
  )
  expect_snapshot(res |> as.data.frame())
  expect_snapshot_value(res$table_styling$header$label[4])

  # errors thrown when bad label argument passed
  expect_snapshot(
    error = TRUE,
    tbl_hierarchical_count(data = trial, variables = c(stage, grade), label = "Stages")
  )
})