tests/testthat/test-riskdiff.R

In atorus-research/Tplyr: A Traceability Focused Grammar of Clinical Data Summary

## Initial set-up and framework exists
test_that("A container named `stats` exists in a new layer", {
  t <- tplyr_table(mtcars, gear)
  l1 <- group_count(t, carb)

  expect_equal(l1$stats, list())
})

## Everything goes in correctly.
test_that("`add_risk_diff` adds an element of the correct type to the `stats` container", {
  t <- tplyr_table(mtcars, gear)
  l1 <- group_count(t, carb) %>%
    add_risk_diff(c('4', '3'))

  # 1 container added with proper class
  expect_equal(length(l1$stats), 1)
  expect_s3_class(l1$stats[[1]], 'tplyr_statistic')
  expect_s3_class(l1$stats[[1]], 'tplyr_riskdiff')

  s <- l1$stats[[1]]
  # Contents of the class are accurate
  expect_equal(s$comparisons, list(c('4', '3')))
  expect_equal(s$args, list())
})

## Can't be applied to a wrong layer type
test_that("`add_risk_diff` can't be applied to a non-count layer", {


  expect_snapshot_error({
    t <- tplyr_table(mtcars, gear) %>%
      add_layer(
        group_desc(mpg) %>%
          add_risk_diff(c('5', '3'))
      )
  })

})

## Parameters are checked and errors are triggered properly.
test_that("Improper parameter entry is handled correctly", {
  t <- tplyr_table(mtcars, gear)
  l1 <- group_count(t, carb)

  # Not character
  expect_snapshot_error({
    l1 %>% add_risk_diff(c(1,2))
  })

  # Not two elements
  expect_snapshot_error({
    l1 %>% add_risk_diff(c('1', '2', '3'))
  })

  # Invalid arguments to prop.test
  expect_snapshot_error({
    l1 %>% add_risk_diff(c('5', '4'), args=list(badname = 2))
  })

})

## Risk difference processes properly with defaults
test_that("Default processing happens correctly", {
  ## Two group comparisons with default options applied
  t <- tplyr_table(mtcars, gear)

  # Basic risk diff for two groups, using defaults
  l1 <- group_count(t, carb) %>%
    # Compare 4 vs. 3, 5 vs. 3
    add_risk_diff(
      c('4', '3')
    )

  # Build and show output
  dat <- suppressWarnings(add_layers(t, l1) %>% build())

  # 5 columns
  expect_equal(ncol(dat), 7)

  # 1 rdiff column (check if rdiff in the names of dat and sum the logicals)
  expect_equal(sum(grepl("rdiff", names(dat), fixed=TRUE)), 1)

  # Correct number of rows (unique values in carb)
  expect_equal(length(unique(mtcars$carb)), nrow(dat))

  # 1st row value is accurate
  # Yes this is a lame test - but it's manually verified. Shut it.
  expect_equal(dat$rdiff_4_3[[1]], " 0.133 (-0.277,  0.543)")

})

## Risk difference processes properly with defaults
test_that("Multiple comparisons properly populate", {
  ## Two group comparisons with default options applied
  t <- tplyr_table(mtcars, gear)

  # Basic risk diff for two groups, using defaults
  l1 <- group_count(t, carb) %>%
    # Compare 4 vs. 3, 5 vs. 3
    add_risk_diff(
      c('4', '3'),
      c('5', '3')
    )

  # Build and show output
  dat <- suppressWarnings(add_layers(t, l1) %>% build())

  # 5 columns
  expect_equal(ncol(dat), 8)

  # 1 rdiff column (check if rdiff in the names of dat and sum the logicals)
  expect_equal(sum(grepl("rdiff", names(dat), fixed=TRUE)), 2)

  # Correct number of rows (unique values in carb)
  expect_equal(length(unique(mtcars$carb)), nrow(dat))

  # 1st row value is accurate
  # Yes this is a lame test - but it's manually verified. Shut it.
  expect_equal(dat$rdiff_5_3[[2]], " 0.133 (-0.484,  0.751)")

})

## Format strings are applied correctly.
test_that("Passing arguments into prop.test update values correctly", {
  ## Two group comparisons with default options applied
  t <- tplyr_table(mtcars, gear)

  # Basic risk diff for two groups, using defaults
  l1 <- group_count(t, carb) %>%
    # Compare 4 vs. 3, 5 vs. 3
    add_risk_diff(
      c('4', '3'),
      args = list(conf.level=.9, correct=FALSE, alternative="less")
    )

  dat <- suppressWarnings(add_layers(t, l1) %>% build())

  expect_equal(dat$rdiff_4_3[[1]], " 0.133 (-1.000,  0.352)")

})

test_that("Invalid name to format string call errors properly", {
  ## Two group comparisons with default options applied
  t <- tplyr_table(mtcars, gear)

  # Basic risk diff for two groups, using defaults
  expect_snapshot_error({
    l1 <- group_count(t, carb) %>%
      # Compare 4 vs. 3, 5 vs. 3
      add_risk_diff(
        c('4', '3')
      ) %>%
      set_format_strings(badname = f_str('xx.xxx', dif))
  })

})

## Format strings are applied correctly.
test_that("Format strings are applied correctly", {
  ## Two group comparisons with default options applied
  t <- tplyr_table(mtcars, gear)

  # Basic risk diff for two groups, using defaults
  l1 <- group_count(t, carb) %>%
    # Compare 4 vs. 3, 5 vs. 3
    add_risk_diff(
      c('4', '3')
    ) %>%
    set_format_strings(
      riskdiff = f_str('xx.xxx, xx.xxx, xx.xxx, xx.xxx, xx.xxx', ref, comp, dif, low, high)
      )

  dat <- suppressWarnings(add_layers(t, l1) %>% build())

  expect_equal(dat$rdiff_4_3[[1]], " 0.200,  0.333,  0.133, -0.277,  0.543")

})

## Format strings are applied correctly.
test_that("Make sure display values accurately reflect prop.test results", {
  ## Two group comparisons with default options applied
  t <- tplyr_table(mtcars, gear)

  # Basic risk diff for two groups, using defaults
  l1 <- group_count(t, carb) %>%
    # Compare 4 vs. 3, 5 vs. 3
    add_risk_diff(
      c('4', '3')
    ) %>%
    set_format_strings(
      riskdiff = f_str('xx.xxxxxx, xx.xxxxxx, xx.xxxxxx, xx.xxxxxx, xx.xxxxxx', comp, ref, dif, low, high)
    )

  # Build the table
  dat <- suppressWarnings(add_layers(t, l1) %>% build())

  # Pick out the available results
  results <- dat$rdiff_4_3[1:4]
  results <- results[results != '']
  results <- map(results, ~ as.numeric(str_split(.x, ", ")[[1]]))

  # Run a manual prop test from the manually checked values
  carb_1 <- suppressWarnings(prop.test(c(4, 3), c(12, 15)))
  carb_2 <- suppressWarnings(prop.test(c(4, 4), c(12, 15)))
  carb_3 <- suppressWarnings(prop.test(c(0, 3), c(12, 15)))
  carb_4 <- suppressWarnings(prop.test(c(4, 5), c(12, 15)))

  # Get the values for carb == 1
  carb_1_res <- unname(
    c(carb_1$estimate[1], carb_1$estimate[2], carb_1$estimate[1] - carb_1$estimate[2], carb_1$conf.int[1], carb_1$conf.int[2])
    )

  # Get the values for carb == 2
  carb_2_res <- unname(
    c(carb_2$estimate[1], carb_2$estimate[2], carb_2$estimate[1] - carb_2$estimate[2], carb_2$conf.int[1], carb_2$conf.int[2])
  )

  # Get the values for carb == 3
  carb_3_res <- unname(
    c(carb_3$estimate[1], carb_3$estimate[2], carb_3$estimate[1] - carb_3$estimate[2], carb_3$conf.int[1], carb_3$conf.int[2])
  )

  # Get the values for carb == 4
  carb_4_res <- unname(
    c(carb_4$estimate[1], carb_4$estimate[2], carb_4$estimate[1] - carb_4$estimate[2], carb_4$conf.int[1], carb_4$conf.int[2])
  )

  expect_equal(results[[2]], carb_2_res, tolerance = .00001)
  expect_equal(results[[3]], carb_3_res, tolerance = .00001)
  expect_equal(results[[4]], carb_4_res, tolerance = .00001)
  expect_equal(results[[1]], carb_1_res, tolerance = .00001)
})

test_that("Distinct or non-distinct values are chosen properly", {
  load(file='adae.Rdata')
  # load(file='vignettes/adae.Rdata')

  ## Two group comparisons with default options applied
  t1 <- tplyr_table(adae, TRTA)
  t2 <- tplyr_table(adae, TRTA)
  t3 <- tplyr_table(adae, TRTA)

  # No distinct variables
  l1 <- group_count(t1, AEBODSYS) %>%
    add_risk_diff(c('Xanomeline High Dose', 'Placebo'))

  # Distinct variables - and use them
  l2 <- group_count(t2, AEBODSYS) %>%
    add_risk_diff(c('Xanomeline High Dose', 'Placebo')) %>%
    set_distinct_by(USUBJID)

  # Distinct variables, don't use them
  l3 <- group_count(t3, AEBODSYS) %>%
    add_risk_diff(c('Xanomeline High Dose', 'Placebo'), distinct=FALSE) %>%
    set_distinct_by(USUBJID)

  dat1 <- suppressWarnings(add_layers(t1, l1) %>% build())
  dat2 <- suppressWarnings(add_layers(t2, l2) %>% build())
  dat3 <- suppressWarnings(add_layers(t3, l3) %>% build())

  expect_true(all(dat1$`rdiff_Xanomeline High Dose_Placebo` == dat3$`rdiff_Xanomeline High Dose_Placebo`))
  expect_true(!all(dat1$`rdiff_Xanomeline High Dose_Placebo` == dat2$`rdiff_Xanomeline High Dose_Placebo`))
  expect_true(!all(dat2$`rdiff_Xanomeline High Dose_Placebo` == dat3$`rdiff_Xanomeline High Dose_Placebo`))

})

test_that("Error generates when duplicating riskdiff comparison values", {

  expect_snapshot_error(
      tplyr_table(mtcars, gear) %>%
        add_layer(
          group_count(cyl) %>%
            add_risk_diff(
              c("4", "4")
            )
        )
  )

})