tests/testthat/test_helpers.R

In wwiecek/baggr: Bayesian Aggregate Treatment Effects

context("baggr helper functions")
library(baggr)
set.seed(1990)

test_that("prepare_ma()", {
  expect_error(prepare_ma(schools), "individual-level")
  expect_error(prepare_ma(microcredit_simplified), "no column")
  expect_warning(prepare_ma(microcredit, outcome = "consumption"))
  expect_warning(prepare_ma(microcredit[!is.na(microcredit$treatment),],
                            outcome = "consumption"))
  expect_error(prepare_ma(microcredit_simplified, outcome = "consumption",
                          effect = "logRR"), "not binary")
  expect_error(prepare_ma(microcredit_simplified, outcome = "consumption",
                          effect = "logOR"), "not binary")

  # Prepare MA without summarising:
  df <- prepare_ma(microcredit_simplified, outcome = "consumption", summarise = F)
  expect_is(df, "data.frame")
  expect_identical(dim(df), dim(microcredit_simplified))
  expect_identical(names(df), c("treatment", "group", "outcome"))

  pm <- prepare_ma(microcredit_simplified, outcome = "consumption")
  expect_is(pm, "data.frame")
  expect_equal(dim(pm), c(5,7))
  expect_identical(names(pm), c("group", "mu", "tau", "se.mu", "se.tau", "n.mu", "n.tau"))

  pm <- prepare_ma(microcredit_simplified, outcome = "consumption", summarise = FALSE)
  expect_identical(dim(pm), dim(microcredit_simplified))

  mc2 <- microcredit_simplified
  names(mc2)[1] <- "study"
  expect_error(prepare_ma(mc2, outcome = "consumption"), "must be individual")
  expect_is(prepare_ma(mc2, group = "study", outcome = "consumption"), "data.frame")

  # prepare_ma for binary data
  df_pat2 <- data.frame(treatment = rbinom(900, 1, .5),
                        group = rep(paste("Trial", LETTERS[1:10]), each = 90))
  df_pat2$outcome <- ifelse(df_pat2$treatment, rbinom(900, 1, .3), rbinom(900, 1, .15))
  expect_is(prepare_ma(df_pat2, effect = "logOR"), "data.frame")
  expect_is(prepare_ma(df_pat2, effect = "logRR"), "data.frame")

})

test_that("binary_to_individual() and prepare_ma() with summary data", {
  df_yusuf <- read.table(text="
  trial  a n1i  c n2i
  Balcon 14  56 15  58
  Clausen 18  66 19  64
  Multicentre 15 100 12  95
  Barber 10  52 12  47
  Norris 21 226 24 228
  Kahler  3  38  6  31
  Ledwich  2  20  3  20
  ", header=TRUE)

  expect_message(binary_to_individual(df_yusuf), "group")
  expect_error(binary_to_individual(cars, group = "speed"), "undefined")

  bti <- binary_to_individual(df_yusuf, group = "trial")
  expect_is(bti, "data.frame")
  expect_equal(nrow(bti), 1101)
  expect_equal(ncol(bti), 3)

  expect_message(prepare_ma(df_yusuf, effect="logOR"), "group")
  agg <- prepare_ma(df_yusuf, group="trial", effect="logOR")
  expect_is(agg, "data.frame")
  expect_equal(nrow(agg), 7)
  expect_equal(ncol(agg), 9)


  expect_identical(
    prepare_ma(bti, effect = "logOR"),
    agg)

  # What if we had different cols
  df_yusuf$b <- df_yusuf$n1i
  df_yusuf$d <- df_yusuf$n2i
  bti <- binary_to_individual(df_yusuf, group = "trial")
  expect_is(bti, "data.frame")
  expect_equal(nrow(bti), 1101)
  expect_equal(ncol(bti), 3)

  # Non-integer number of events
  df_yusuf2 <- read.table(text="
  trial  a n1i  c n2i
  Balcon 14  56.1 15  58
  Clausen 18  66 19  64
  Multicentre 15 100 12  95
  ", header=TRUE)
  expect_error(binary_to_individual(df_yusuf2, group = "trial"), "Non-integer number")

  # Add some covariates to the data frame
  df_yusuf3 <- df_yusuf
  df_yusuf3$bbb <- rnorm(nrow(df_yusuf)) > 0
  df_yusuf3$aaa <- rnorm(nrow(df_yusuf))

  bti <- binary_to_individual(df_yusuf3, group = "trial", covariates = c("bbb", "aaa"))
  expect_is(bti, "data.frame")
  expect_equal(nrow(bti), 1101)
  expect_equal(ncol(bti), 5)
  expect_equal(names(bti), c("group", "treatment", "outcome", "bbb", "aaa"))
})



test_that("labbe()", {
  df_yusuf <- read.table(text="
  trial  a n1i  c n2i
  Balcon 14  56 15  58
  Clausen 18  66 19  64
  Multicentre 15 100 12  95
  Barber 10  52 12  47
  Norris 21 226 24 228
  Kahler  3  38  6  31
  Ledwich  2  20  3  20
  ", header=TRUE)

  gg <- labbe(df_yusuf, group = "trial")
  expect_is(gg, "gg")

  gg2 <- suppressWarnings(labbe(df_yusuf, plot_model = TRUE,
                                shade_se = "rr", labels = FALSE))
  expect_is(labbe(df_yusuf, shade_se = "rr"), "gg")
  expect_is(gg2, "gg")


})



test_that("convert_inputs()", {
  # Rubin model
  expect_is(convert_inputs(schools, "rubin"), "list")
  expect_error(convert_inputs(schools, "mutau"))
  expect_is(convert_inputs(schools, "rubin", test_data = schools[7:8,]), "list")
})

test_that("mint()", {
  # Rubin model
  expect_length(mint(rnorm(100)), 3)
  expect_length(mint(rnorm(100), sd = TRUE), 4)
  expect_length(mint(rnorm(100), median = TRUE, sd = TRUE), 5)
  expect_length(mint(rnorm(100), median = TRUE, sd = TRUE, int = .5), 5)
  expect_identical(names(mint(rnorm(100), median = TRUE, sd = TRUE, int = .5)),
                   c("25%", "mean", "75%", "median", "sd"))
})

test_that("We can set and get baggr theme", {
  expect_is(baggr_theme_get(), "theme")
  expect_is(baggr_theme_update(), "theme")
  expect_is(baggr_theme_replace(), "theme")
  capture_output(baggr_theme_set(ggplot2::theme_bw()))
})

test_that("silent_messages option", {
  expect_message(baggr(schools,
                       control = list(adapt_delta = 0.99999),
                       refresh = 0
  )
  )
  expect_silent(baggr(schools,
                      control = list(adapt_delta = 0.99999),
                      refresh = 0,
                      silent = TRUE)
  )
}
)