tests/testthat/test-helpers-data.R

In bmm: Easy and Accessible Bayesian Measurement Models Using 'brms'

test_that("check_data() produces expected errors and warnings", {
  expect_error(
    check_data(.model_mixture2p(resp_error = "y")),
    "Data must be specified using the 'data' argument."
  )
  expect_error(
    check_data(
      .model_mixture2p(resp_error = "y"),
      data.frame(),
      bmmformula(kappa ~ 1)
    ),
    "Argument 'data' does not contain observations."
  )
  expect_error(
    check_data(
      .model_mixture2p(resp_error = "y"),
      data.frame(x = 1),
      bmmformula(kappa ~ 1)
    ),
    "The response variable 'y' is not present in the data."
  )
  expect_error(
    check_data(
      .model_mixture2p(resp_error = "y"),
      y ~ 1
    ),
    "Argument 'data' must be coercible to a data.frame."
  )

  mls <- lapply(c("mixture2p", "mixture3p", "imm"), get_model)
  for (ml in mls) {
    expect_warning(
      check_data(
        ml(resp_error = "y", nt_features = "x", set_size = 2, nt_distances = "z"),
        data.frame(y = 12, x = 1, z = 2),
        bmmformula(kappa ~ 1)
      ),
      "It appears your response variable is in degrees.\n"
    )
    expect_silent(check_data(
      ml(resp_error = "y", nt_features = "x", set_size = 2, nt_distances = "z"),
      data.frame(y = 1, x = 1, z = 2), bmmformula(y ~ 1)
    ))
  }

  mls <- lapply(c("mixture3p", "imm"), get_model)
  for (ml in mls) {
    expect_error(
      check_data(
        ml(resp_error = "y", nt_features = "x", set_size = 5, nt_distances = "z"),
        data.frame(y = 1, x = 1, z = 2),
        bmmformula(kappa ~ 1)
      ),
      "'nt_features' should equal max\\(set_size\\)-1"
    )
    expect_warning(
      check_data(
        ml(resp_error = "y", nt_features = "x", set_size = 2, nt_distances = "z"),
        data.frame(y = 1, x = 2 * pi + 1, z = 2),
        bmmformula(kappa ~ 1)
      ),
      "at least one of your non_target variables are in degrees"
    )
  }

  for (version in c("bsc", "full")) {
    expect_error(
      check_data(
        imm(resp_error = "y", nt_features = paste0("x", 1:4), set_size = 5,
            nt_distances = "z", version = version),
        data.frame(y = 1, x1 = 1, x2 = 2, x3 = 3, x4 = 4, z = 2),
        bmmformula(kappa ~ 1)
      ),
      "'nt_distances' should equal max\\(set_size\\)-1"
    )
  }
})



test_that("check_var_set_size accepts valid input", {
  # Simple numeric vector is valid
  dat <- data.frame(y = rep(c(1,2,3), each=3))
  expect_silent(check_var_set_size('y', dat))
  expect_equal(names(check_var_set_size('y', dat)), c("max_set_size","ss_numeric"))
  expect_equal(check_var_set_size('y', dat)$max_set_size, 3)
  all(is.numeric(check_var_set_size('y', dat)$ss_numeric), na.rm = T)

  # Factor with numeric levels is valid
  dat <- data.frame(y = factor(rep(c(1,2,3), each=3)))
  expect_silent(check_var_set_size('y', dat))
  expect_equal(check_var_set_size('y', dat)$max_set_size, 3)
  all(is.numeric(check_var_set_size('y', dat)$ss_numeric), na.rm = T)


  # Character vector representing numbers is valid
  dat <- data.frame(y = rep(c('1','2','3'), each=3))
  expect_silent(check_var_set_size('y', dat))
  expect_equal(check_var_set_size('y', dat)$max_set_size, 3)
  all(is.numeric(check_var_set_size('y', dat)$ss_numeric), na.rm = T)


  # Numeric vector with NA values is valid (assuming NA is treated correctly)
  dat <- data.frame(y = rep(c(1,5,NA), each=3))
  expect_silent(check_var_set_size('y', dat))
  expect_equal(check_var_set_size('y', dat)$max_set_size, 5)
  all(is.numeric(check_var_set_size('y', dat)$ss_numeric), na.rm = T)


  # Factor with NA and numeric levels is valid
  dat <- data.frame(y = factor(rep(c(1,5,NA), each=3)))
  expect_silent(check_var_set_size('y', dat))
  expect_equal(check_var_set_size('y', dat)$max_set_size, 5)
  all(is.numeric(check_var_set_size('y', dat)$ss_numeric), na.rm = T)

})

test_that("check_var_set_size rejects invalid input", {
  # Factor with non-numeric levels is invalid
  dat <- data.frame(y = factor(rep(c('A','B','C'), each=3)))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Character vector with non-numeric values is invalid
  dat <- data.frame(y = rep(c('A','B','C'), each=3))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Character vector with NA and non-numeric values is invalid
  dat <- data.frame(y = rep(c('A',NA,'C'), each=3))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Factor with NA and non-numeric levels is invalid
  dat <- data.frame(y = factor(rep(c('A',NA,'C'), each=3)))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Character vector with numeric and non-numeric values is invalid
  dat <- data.frame(y = rep(c('A',5,'C'), each=3))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Factor with numeric and non-numeric levels is invalid
  dat <- data.frame(y = factor(rep(c('A',5,'C'), each=3)))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Numeric vector with invalid set sizes (less than 1) is invalid
  dat <- data.frame(y = rep(c(0,1,5), each=3))
  expect_error(check_var_set_size('y', dat), "must be greater than 0")

  # Factor with levels less than 1 are invalid
  dat <- data.frame(y = factor(rep(c(0,4,5), each=3)))
  expect_error(check_var_set_size('y', dat), "must be greater than 0")

  # Character vector representing set sizes with text is invalid
  dat <- data.frame(y = rep(paste0('set_size ', c(2,3,8)), each=3))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Factor representing set sizes with text is invalid
  dat <- data.frame(y = factor(rep(paste0('set_size ', c(2,3,8)), each=3)))
  expect_error(check_var_set_size('y', dat), "must be coercible to a numeric vector")

  # Numeric vector with decimals is invalid
  dat <- data.frame(y = c(1:8,1.3))
  expect_error(check_var_set_size('y', dat), "must be whole numbers")

  # Setsize must be of length 1
  dat <- data.frame(y = c(1,2,3), z = c(1,2,3))
  expect_error(check_var_set_size(c('z','y'), dat), "You provided a vector")
  expect_error(check_var_set_size(list('z','y'), dat), "You provided a vector")
  expect_error(check_var_set_size(set_size=TRUE, dat),
               "must be either a variable in your data or a single numeric value")
})






test_that("check_data() returns a data.frame()", {
  mls <- lapply(supported_models(print_call = FALSE), get_model)
  for (ml in mls) {
    expect_s3_class(check_data(
      ml(resp_error = "y", nt_features = "x", set_size = 2, nt_distances = "z"),
      data.frame(y = 1, x = 1, z = 2),
      bmmformula(kappa ~ 1)
    ), "data.frame")
  }
})



test_that("wrap(x) returns the same for values between -pi and pi", {
  x <- runif(100, -pi, pi)
  expect_equal(wrap(x), x)
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})

test_that("wrap(x) returns the correct value for values between (pi, 2*pi)", {
  x <- pi+1
  expect_equal(wrap(x), -(pi-1))
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})


test_that("wrap(x) returns the correct value for values between (-2*pi, -pi)", {
  x <- -pi-1
  expect_equal(wrap(x), pi-1)
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})

test_that("wrap(x) returns the correct value for values over 2*pi", {
  x <- 2*pi+1
  expect_equal(wrap(x), 1)
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})

test_that("wrap(x) returns the correct value for values between (3*pi,4*pi)", {
  x <- 3*pi+1
  expect_equal(wrap(x), -(pi-1))
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})


test_that("deg2rad returns the correct values for 0, 180, 360", {
  x <- c(0,90,180)
  expect_equal(round(deg2rad(x),2),c(0.00,1.57,3.14))
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})

test_that("rad2deg returns the correct values for 0, pi/2, 2*pi", {
  x <- c(0, pi/2, 2*pi)
  expect_equal(round(rad2deg(x),2),c(0,90,360))
  expect_equal(wrap(rad2deg(x), radians = F), rad2deg(wrap(x)))
})

test_that("standata() works with brmsformula", {
  ff <- brms::bf(count ~ zAge + zBase * Trt + (1|patient))
  sd <- standata(ff, data = brms::epilepsy, family = poisson())
  expect_equal(class(sd)[1], "standata")
})

test_that("standata() works with formula", {
  ff <- count ~ zAge + zBase * Trt + (1|patient)
  sd <- standata(ff, data = brms::epilepsy, family = poisson())
  expect_equal(class(sd)[1], "standata")
})

test_that("standata() works with bmmformula", {
  ff <- bmmformula(kappa ~ 1, thetat ~ 1, thetant ~ 1)
  dat <- oberauer_lin_2017
  sd <- standata(ff, dat, mixture3p(resp_error = "dev_rad",
                                   nt_features = 'col_nt',
                                   set_size = "set_size", regex = T))
  expect_equal(class(sd)[1], "standata")
})

test_that("standata() returns a standata class", {
  ff <- bmmformula(kappa ~ 1,
                   thetat ~ 1,
                   thetant ~ 1)

  dat <- data.frame(y = rmixture3p(n = 3),
                    nt1_loc = 2,
                    nt2_loc = -1.5)

  standata <- standata(ff, dat, mixture3p(resp_error = "y" ,
                                          nt_features = paste0('nt',1,'_loc'),
                                          set_size = 2))
  expect_equal(class(standata)[1], "standata")
})


# first draft of tests was written by ChatGPT4
test_that('has_nonconsecutive_duplicates works', {
  # Test with a vector that has only consecutive duplicates
  expect_false(has_nonconsecutive_duplicates(c("a", "a", "b", "b", "c", "c")))

  # Test with a vector that has non-consecutive duplicates
  expect_true(has_nonconsecutive_duplicates(c("a", "b", "a", "c", "c", "b")))

  # Test with a single unique value repeated
  expect_false(has_nonconsecutive_duplicates(rep("a", 5)))

  # Test with a vector of all unique values
  expect_false(has_nonconsecutive_duplicates(letters[1:5]))

  # Test with a vector that has a mix of consecutive and non-consecutive duplicates
  expect_true(has_nonconsecutive_duplicates(c("a", "a", "b", "a", "b", "b")))

  # Test with a numeric vector with mixed values
  expect_true(has_nonconsecutive_duplicates(c(1, 2, 3, 1, 4, 2)))

  # Test with an empty vector
  expect_false(has_nonconsecutive_duplicates(numeric(0)))

  # Test with a vector that has only one element
  expect_false(has_nonconsecutive_duplicates(c("a")))

  # Test with a vector that has non-consecutive duplicates at the beginning and end
  expect_true(has_nonconsecutive_duplicates(c("a", "b", "b", "a")))

  # Test with a vector that includes NA values
  expect_false(has_nonconsecutive_duplicates(c(NA, NA, NA)))

  # Test with a vector that includes NA values among other values
  expect_false(has_nonconsecutive_duplicates(c(NA, 1, NA)))

  # Test with a complex vector including numbers, NA, and characters
  expect_true(has_nonconsecutive_duplicates(c(1, "a", 2, "b", 1, NA, "a")))

  # Test with a vector that changes type (numeric and character mixed)
  expect_true(has_nonconsecutive_duplicates(c("1", 2, "2", 1)))
})

test_that('is_data_ordered works', {
  # Test with a data frame that is ordered
  data1 <- expand.grid(y = 1:3, B = 1:3, C = 1:3)
  formula1 <- bmf(y ~ B + C)
  expect_true(is_data_ordered(data1, formula1))

  # Test with a data frame that is not ordered
  data2 <- rbind(data1, data1[1, ])
  expect_false(is_data_ordered(data2, formula1))

  # Test when irrelevant variables are not ordered but predictors are
  data3 <- data1
  data3$A <- c(3, 2, 2, 1, 2, 1, 3, 1, 3, 3, 1, 2, 2, 1, 1, 1, 3, 3, 1, 3, 2, 3, 1, 2, 3, 2, 2)
  formula2 <- bmf(y ~ A + B + C)
  expect_true(is_data_ordered(data3, formula1))
  expect_false(is_data_ordered(data3, formula2))

  # test with a complex formula with shared covariance structure across parameters
  data <- oberauer_lin_2017
  formula <- bmf(c ~ 0 + set_size + (0 + set_size | p1 | ID),
                 kappa ~ 0 + set_size + (0 + set_size | p1 | ID))
  expect_false(is_data_ordered(data, formula))

  data <- dplyr::arrange(data, set_size, ID)
  expect_true(is_data_ordered(data, formula))
})

test_that('is_data_ordered works when there is only one predictor', {
  # Test with a data frame that is ordered
  data <- data.frame(y = rep(1:3, each=2),
                      B = rep(1:3, each=2),
                      C = factor(rep(1:3, each=2)),
                      D = rep(1:3, times=2),
                      E = factor(rep(1:3, times=2)))
  expect_true(is_data_ordered(data, y ~ B))

  # Test with a data frame that is not ordered
  expect_false(is_data_ordered(data, y ~ D))

  # Test with a data frame that is ordered and predictor is a factor
  expect_true(is_data_ordered(data, y ~ C))

  # Test with a data frame that is not ordered and predictor is a factor
  expect_false(is_data_ordered(data, y ~ E))
})

test_that('is_data_ordered works when there are no predictors', {
  # Test with a data frame that is ordered
  data <- data.frame(y = 1:3)
  expect_true(is_data_ordered(data, y ~ 1))
})

test_that('is_data_ordered works when there are non-linear predictors', {
  data <- data.frame(y = rep(1:3, each=2),
                     B = rep(1:3, each=2),
                     C = rep(1:3, times=2))
  # Test with a data frame that is ordered
  formula1 <- bmf(y ~ nlD,
                  nlD ~ B)
  expect_true(is_data_ordered(data, formula1))

  # Test with a data frame that is not ordered
  formula2 <- bmf(y ~ nlD,
                  nlD ~ C)
  expect_false(is_data_ordered(data, formula2))
})