tests/testthat/test_prospective.R

In ClaudioZandonella/PRDAbeta: Conduct a Prospective or Retrospective Design Analysis

###############################
####    Test prospective   ####
###############################

library(PRDA)

#----    input checks    ----

context("prospective inputs specification")




test_that("inputs are correctly specified", {

  # Redefine function to avoid specify arguments each the times
  test_prospective <- function(effect_size = .3, power = .8, ratio_n = 1,
                         effect_type = "correlation", test_method = "pearson",
                         alternative = "two_sided", sig_level = .05,
                         ratio_sd = 1, B = 10, tl = -Inf, tu = Inf,
                         B_effect = 10, sample_range = c(2, 1000),
                         eval_power = "mean", tol = .01,
                         display_message = FALSE, seed = 2020){
    prospective(effect_size, power, ratio_n, effect_type, test_method,
                alternative, sig_level, ratio_sd, B, tl, tu, B_effect,
                sample_range, eval_power, tol, display_message, seed)
  }

  #----    Arguments    ----

  # effect_size
  effect_size_text <- "Argument 'effect_size' has to be a single numeric value or a function"
  expect_error(test_prospective(effect_size = Inf), effect_size_text)
  expect_error(test_prospective(effect_size = "ciao"), effect_size_text)
  expect_error(test_prospective(effect_size = c(1,2)), effect_size_text)

  # power
  power_text <- "Argument 'power' has to be a single value between 0 and 1"
  expect_error(test_prospective(power = Inf), power_text)
  expect_error(test_prospective(power = "ciao"), power_text)
  expect_error(test_prospective(power = c(.5,.6)), power_text)
  expect_error(test_prospective(power = 1), power_text)
  expect_error(test_prospective(power = -1), power_text)

  # ratio_n
  ratio_n_text <- "If specified, argument 'ratio_n' has to be a single positive value"
  expect_error(test_prospective(ratio_n = Inf), ratio_n_text)
  expect_error(test_prospective(ratio_n = "ciao"), ratio_n_text)
  expect_error(test_prospective(ratio_n = c(.5,.6)), ratio_n_text)
  expect_error(test_prospective(ratio_n = -.5), ratio_n_text)

  # sig_level
  sig_level_text <- "Argument 'sig_level' has to be a single value between 0 and 1"
  expect_error(test_prospective(sig_level = 1), sig_level_text)
  expect_error(test_prospective(sig_level = Inf), sig_level_text)
  expect_error(test_prospective(sig_level = 0), sig_level_text)
  expect_error(test_prospective(sig_level = "ciao"), sig_level_text)
  expect_error(test_prospective(sig_level = c(.1,.2)), sig_level_text)

  # ratio_sd
  ratio_sd_text <- "Argument 'ratio_sd' has to be a single finite number grater than 0"
  expect_error(test_prospective(ratio_sd = -1), ratio_sd_text)
  expect_error(test_prospective(ratio_sd = Inf), ratio_sd_text)
  expect_error(test_prospective(ratio_sd = 0), ratio_sd_text)
  expect_error(test_prospective(ratio_sd = "ciao"), ratio_sd_text)
  expect_error(test_prospective(ratio_sd = c(.1,.2)), ratio_sd_text)

  # B
  B_text <- "Argument 'B' has to be a single integer value grater than 1"
  expect_error(test_prospective(B = 1), B_text)
  expect_error(test_prospective(B = Inf), B_text)
  expect_error(test_prospective(B = "ciao"), B_text)
  expect_error(test_prospective(B = c(10,20)), B_text)

  # seed
  seed_text <- "If specified, argument 'seed' has to be a single finite number"
  expect_error(test_prospective(seed = Inf), seed_text)
  expect_error(test_prospective(seed = "ciao"), seed_text)
  expect_error(test_prospective(seed = c(10,20)), seed_text)

  # tl
  tl_text <- "Argument 'tl' has to be a single numeric value"
  expect_error(test_prospective(tl = "ciao"), tl_text)
  expect_error(test_prospective(tl = c(10,20)), tl_text)

  # tu
  tu_text <- "Argument 'tu' has to be a single numeric value"
  expect_error(test_prospective(tu = "ciao"), tu_text)
  expect_error(test_prospective(tu = c(10,20)), tu_text)

  # B_effect
  B_effect_text <- "Argument 'B_effect' has to be a single integer value grater than 1"
  expect_error(test_prospective(B_effect = 1), B_effect_text)
  expect_error(test_prospective(B_effect = Inf), B_effect_text)
  expect_error(test_prospective(B_effect = "ciao"), B_effect_text)
  expect_error(test_prospective(B_effect = c(10,20)), B_effect_text)

  # sample_range
  sample_range_text1 <- "Argument 'sample_range' has to be a length-2 numeric vector"
  sample_range_text2 <- "Argument 'sample_range' minimum has to be grater than 1 and less than sample range maximum"
  expect_error(test_prospective(sample_range = 1), sample_range_text1)
  expect_error(test_prospective(sample_range = c(10,20,20)), sample_range_text1)
  expect_error(test_prospective(sample_range = c(10,"20")), sample_range_text1)
  expect_error(test_prospective(sample_range = c(10,Inf)), sample_range_text1)
  expect_error(test_prospective(sample_range = c(10,8)), sample_range_text2)
  expect_error(test_prospective(sample_range = c(1,8)), sample_range_text2)

  # tol
  tol_text <- "Argument 'tol' has to be a single value between 0 and 1"
  expect_error(test_prospective(tol = 1), tol_text)
  expect_error(test_prospective(tol = Inf), tol_text)
  expect_error(test_prospective(tol = 0), tol_text)
  expect_error(test_prospective(tol = "ciao"), tol_text)
  expect_error(test_prospective(tol = c(.1,.2)), tol_text)

  # display_message
  display_text <- "Argument 'display_message' has to be logical"
  expect_error(test_prospective(display_message = 1), display_text)
  expect_error(test_prospective(display_message = Inf), display_text)
  expect_error(test_prospective(display_message = NULL), display_text)
  expect_error(test_prospective(display_message = "ciao"), display_text)
  expect_error(test_prospective(display_message = c(.1,.2)), display_text)


  #----    Other cases    ----

  # coherence effect_type and test_method
  coherence_corr <- "If  'effect_type = correlation', argument 'test_method' has to be 'pearson'"
  expect_error(test_prospective(effect_type = "correlation", test_method = "paired"),
               coherence_corr)
  coherence_cohen <- "No appropriate 'test_method' for 'effect_type = cohen_d'"
  expect_error(test_prospective(effect_type = "cohen_d", test_method = "pearson"),
               coherence_cohen)

  # correlation and ratio_n
  correlation_text <- "If 'effect_type = correlation', argument 'ratio_n' is set to NULL"
  expect_warning(test_prospective(effect_type = "correlation", test_method = "pearson",
                                  ratio_n = 2), correlation_text)

  # one_sample and ratio_n
  one_sample_text <- "If 'test_method = one_sample', argument 'ratio_n' must be set to NULL"
  expect_error(test_prospective(ratio_n = 3, effect_type = "cohen_d", test_method = "one_sample"),
               one_sample_text)

  # paired and ratio_n
  paired_text <- "If 'test_method = paired', argument 'ratio_n' has to be 1"
  expect_error(test_prospective(effect_type = "cohen_d", test_method = "paired", ratio_n = 2),
                 paired_text)
  expect_error(test_prospective(effect_type = "cohen_d", test_method = "paired", ratio_n = NULL),
               paired_text)

  # two_sample or welch and ratio_n
  t_test_text <- "Argument 'ratio_n' is required for the specified 'test_method'"
  expect_error(test_prospective(ratio_n = NULL, effect_type = "cohen_d", test_method = "two_sample"),
               t_test_text)
  expect_error(test_prospective(ratio_n = NULL, effect_type = "cohen_d", test_method = "welch"),
               t_test_text)

  # sample_range
  sample_range <- "Actual power = 0.1 with n = 100\n  try to increase maximum of sample_range > 100."
  expect_error(test_prospective(effect_size = .1, effect_type = "cohen_d", test_method = "two_sample",
                                sample_range =  c(5,100), B=100), sample_range)

  # tol issue
  tol_text <- "Required power according to tolerance value can not be obtained.\nIncrease tolerance value."
  expect_message(test_prospective(effect_size = .35, B=100, sample_range = c(40,120),
                                  tol=.001), tol_text)

  # welch and ratio_sd
  t_test_ratio_text1 <- "Argument 'ratio_sd' is required only for 'test_method = welch'"
  t_test_ratio_text2 <- "Argument 'ratio_sd' can not be 1 for 'test_method = welch'\n  Consider 'test_method = two_sample' instead"
  expect_error(test_prospective(ratio_sd = 1.5, effect_type = "cohen_d", test_method = "two_sample"),
               t_test_ratio_text1)
  expect_error(test_prospective(ratio_sd = 1, effect_type = "cohen_d", test_method = "welch"),
               t_test_ratio_text2)
})


#----    obtain same results    ----

test_that("same results as previous run", {
  expect_known_value(prospective(effect_size = .3, power = .8, ratio_n = 1, B = 100, seed = 2020, display_message = FALSE)$effect_info,
                     file = "test_cache/effect_info_single_pro_cor", update= FALSE)
  expect_known_value(prospective(effect_size = .3, power = .8, ratio_n = 1, B = 100, seed = 2020, display_message = FALSE,
                                 effect_type = "cohen_d", test_method = "two_sample")$effect_info,
                     file = "test_cache/effect_info_single_pro_cohen", update= FALSE)
  expect_known_value(prospective(effect_size = .3, power = .8, ratio_n = 1, effect_type = "correlation", B = 100, seed = 2020, display_message = FALSE)$prospective_res,
                     file="test_cache/res_corr_single_pro", update= FALSE)
  expect_known_value(prospective(effect_size = .3, power = .8, ratio_n = NULL, effect_type = "cohen_d", test_method = "one_sample", B = 100, seed = 2020, display_message = FALSE)$prospective_res,
                     file="test_cache/res_one_sample_single_pro", update= FALSE)
  expect_known_value(prospective(effect_size = .3, power = .8, effect_type = "cohen_d", test_method = "paired", B = 100, seed = 2020, display_message = FALSE)$prospective_res,
                     file="test_cache/res_cohen_paired_pro", update= FALSE)
  expect_known_value(prospective(effect_size = .3, power = .8, ratio_n = 1, effect_type = "cohen_d", test_method = "welch", ratio_sd = 1.5, B = 100, seed = 2020, display_message = FALSE)$prospective_res,
                     file="test_cache/res_cohen_single_pro", update= FALSE)
  expect_known_value(prospective(effect_size = .3, power = .8, ratio_n = 2, effect_type = "cohen_d", test_method = "two_sample", B = 100, seed = 2020, display_message = FALSE)$prospective_res,
                     file="test_cache/res_cohen_ratio_n_pro", update= FALSE)


  expect_known_value(prospective(effect_size = function(x) rnorm(x), effect_type = "cohen_d", test_method = "welch", ratio_sd = 1.5, power = .8, ratio_n = 1, B = 100, B_effect = 10, seed = 2020, display_message = FALSE)$effect_info,
                     file = "test_cache/effect_info_dist_pro",update= FALSE)
  expect_known_value(prospective(effect_size = function(x) rnorm(x), power = .8, ratio_n = 1, effect_type = "correlation",
                                 B = 100, B_effect = 10, seed = 2020, eval_power = "mean", display_message = FALSE)$prospective_res,
                     file = "test_cache/res_corr_dist_pro",update= FALSE)
  expect_known_value(prospective(effect_size = function(x) rnorm(x), power = .8, ratio_n = NULL, effect_type = "cohen_d", test_method = "one_sample",
                                 B = 100, B_effect = 10, seed = 2020, eval_power = "mean", display_message = FALSE)$prospective_res,
                     file = "test_cache/res_one_sample_dist_pro",update= FALSE)
  expect_known_value(prospective(effect_size = function(x) rnorm(x), power = .8, ratio_n = 1, effect_type = "cohen_d", test_method = "welch", ratio_sd = 1.5,
                                 B = 100, B_effect = 10, seed = 2020, eval_power = "mean", display_message = FALSE)$prospective_res,
                     file = "test_cache/res_cohen_dist_pro",update= FALSE)

})


#----