tests/testthat/test-layer_templates.R

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

op <- options()

# Template doesn't exist
load(test_path('adsl.Rdata'))

test_that("Template errors correctly upon creation", {

  # Enforce ellipsis
  # Invalid starting place
  expect_snapshot_error(
    new_layer_template(
      "test_template",
      set_format_strings()
      )
  )

  # Didn't use ellispsis
  expect_snapshot_error(
    new_layer_template(
      "test_template",
      group_count(adsl, TRT01P)
    )
  )

  # Non-Tplyr functions
  expect_snapshot_error(
    new_layer_template(
      "test_template",
      group_count(...) %>%
        print()
    )
  )

  # template exists warning
  expect_warning({
    new_layer_template("test_template", group_count(...))
    new_layer_template("test_template", group_count(...))
  })

  # This makes sense here - remove_layer_template effectively removes layer templates
  expect_silent(remove_layer_template("test_template"))
  expect_true(!("test_template" %in% names(getOption('tplyr.layer_templates'))))
  expect_warning(remove_layer_template("test_template"), "No template named")
})

test_that("Templates create effectively", {
  # Basic template
  expect_silent(
    new_layer_template(
      "test_template",
      group_count(...)
      )
  )

  expect_true('test_template' %in% names(getOption('tplyr.layer_templates')))

  remove_layer_template("test_template")

  # Templates identify additional params
  new_layer_template(
    "test_template",
    group_count(...) %>%
      set_order_count_method({sort_meth}) %>%
      set_ordering_cols({sort_col})
    )

  expect_equal(attr(get_layer_template('test_template'), 'params'), c("sort_meth", "sort_col"))

  remove_layer_template("test_template")
})

test_that("Template errors correctly upon execution", {
  new_layer_template(
    "test1",
    group_count(...) %>%
      set_format_strings(f_str("xx (xx.x%)", n, pct))
  )

  new_layer_template(
    "test2",
    group_count(...) %>%
      set_format_strings(f_str("xx (xx.x%)", n, pct)) %>%
      set_order_count_method({sort_meth}) %>%
      set_ordering_cols({sort_col})
  )

  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('bad', RACE)
      )
  )

  # Args aren't in list
  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('test2', RACE, add_params = "bad")
      )
  )

  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('test2', RACE, add_params = vars(USUBJID))
      )
  )

  # Args must be named
  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('test2', RACE, add_params = list("bycount"))
      )
  )

  # Invalid template
  options('tplyr.layer_templates' = append(getOption('tplyr.layer_templates'), list(bad = "bad")))

  # Args must be named
  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('bad', RACE)
      )
  )

  remove_layer_template("bad")

  # Param mismatches
  # Extra param in call
  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('test2', RACE, add_params = list(
          sort_meth = "bycount",
          sort_col = Placebo,
          test = vars(a, b, c)
        ))
      )
  )
  # Missing param in call
  expect_snapshot_error(
    tplyr_table(adsl, TRT01P) %>%
      add_layer(
        use_template('test2', RACE, add_params = list(
          sort_meth = "bycount"
        ))
      )
  )

  remove_layer_template("test1")
  remove_layer_template("test2")
})

test_that("Templates can be used correctly", {
  new_layer_template(
    "test1",
    group_count(...) %>%
      set_format_strings(f_str("xx (xx.x%)", n, pct))
  )

  new_layer_template(
    "test2",
    group_count(...) %>%
      set_format_strings(f_str("xx (xx.x%)", n, pct)) %>%
      set_order_count_method({sort_meth}) %>%
      set_ordering_cols({sort_col})
  )

  # NULL params on template without params
  t1 <- tplyr_table(adsl, TRT01P) %>%
    add_layer(
      group_count(RACE) %>%
        set_format_strings(f_str("xx (xx.x%)", n, pct))
    ) %>%
    build()

  t2 <- tplyr_table(adsl, TRT01P) %>%
    add_layer(
      use_template("test1", RACE)
    ) %>%
    build()

  expect_equal(t1, t2)

  # Params passed through - this tests both quoted and non-quoted args
  t3 <- tplyr_table(adsl, TRT01P) %>%
    add_layer(
      group_count(RACE, by=ETHNIC) %>%
        set_format_strings(f_str("xx (xx.x%)", n, pct)) %>%
        set_order_count_method("bycount") %>%
        set_ordering_cols(`Xanomeline Low Dose`)
    ) %>%
    build()

  t4 <- tplyr_table(adsl, TRT01P) %>%
    add_layer(
      use_template("test2", RACE, by=ETHNIC, add_params =
                     list(
                       sort_meth = "bycount",
                       sort_col = `Xanomeline Low Dose`
                     ))
    ) %>%
    build()

  expect_equal(t3, t4)
})

test_that("Templates are extensible", {

  t1 <- tplyr_table(adsl, TRT01P) %>%
    add_layer(
      group_count(RACE) %>%
        set_format_strings(f_str("xx (xx.x%)", n, pct)) %>%
        add_total_row()
    ) %>%
    build()

  t2 <- tplyr_table(adsl, TRT01P) %>%
    add_layer(
      use_template("test1", RACE) %>%
        add_total_row()
    ) %>%
    build()

  expect_equal(t1, t2)

})

test_that("Templates print appropriately", {
  expect_snapshot_output(get_layer_templates())
})

options(op)