tests/testthat/test-cpm.R

In cpmr: Connectome Predictive Modelling in R

test_that("Default threshold method works", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  result <- cpm(conmat, behav)
  expect_s3_class(result, "cpm")
  expect_snapshot_value(result$pred, style = "json2")
  expect_snapshot_value(result$edges, style = "json2")
  expect_snapshot_value(result$params, style = "json2")
  expect_snapshot(result)
})

test_that("`kfolds` works", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  result <- cpm(conmat, behav, kfolds = 5)
  expect_s3_class(result, "cpm")
  expect_snapshot_value(result$pred, style = "json2")
  expect_snapshot_value(result$edges, style = "json2")
  expect_snapshot_value(result$params, style = "json2")
  expect_snapshot(result)
})

test_that("Alternative threshold method works", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  result <- cpm(conmat, behav, thresh_method = "sparsity")
  expect_s3_class(result, "cpm")
  expect_snapshot_value(result$pred, style = "json2")
  expect_snapshot_value(result$edges, style = "json2")
  expect_snapshot_value(result$params, style = "json2")
  expect_snapshot(result)
})

test_that("Different threshold levels works", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  result <- cpm(conmat, behav, thresh_level = 0.1)
  expect_s3_class(result, "cpm")
  expect_snapshot_value(result$pred, style = "json2")
  expect_snapshot_value(result$edges, style = "json2")
  expect_snapshot_value(result$params, style = "json2")
  expect_snapshot(result)
})

test_that("Works with confounds", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  confounds <- matrix(rnorm(10), ncol = 1)
  result <- cpm(conmat, behav, confounds = confounds)
  expect_s3_class(result, "cpm")
  expect_snapshot_value(result$pred, style = "json2", tolerance = 1e-6)
  expect_snapshot_value(result$edges, style = "json2")
  expect_snapshot_value(result$params, style = "json2")
  expect_snapshot(result)
})

test_that("Keep names of behavior", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  names(behav) <- LETTERS[1:10]
  result <- cpm(conmat, behav)
  expect_named(result$real, LETTERS[1:10])
  expect_identical(rownames(result$pred), LETTERS[1:10])
})

test_that("`return_edges` argument works", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  result <- cpm(conmat, behav, return_edges = "none")
  expect_null(result$edges)
  expect_snapshot(result)
  result <- cpm(conmat, behav, return_edges = "all")
  expect_snapshot_value(result$edges, style = "json2")
  expect_snapshot(result)
})

test_that("Support row/column matrix input of `behav` and `confounds`", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  result <- cpm(conmat, behav)
  key_fields <- c("real", "pred", "edges")
  expect_identical(
    cpm(conmat, matrix(behav, ncol = 1))[key_fields],
    result[key_fields]
  )
  expect_identical(
    cpm(conmat, matrix(behav, nrow = 1))[key_fields],
    result[key_fields]
  )
  confounds <- matrix(rnorm(10), ncol = 1)
  result <- cpm(conmat, behav, confounds = confounds)
  expect_identical(
    cpm(conmat, behav, confounds = drop(confounds))[key_fields],
    result[key_fields]
  )
})

test_that("Throw informative error if data checking not pass", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  expect_error(
    cpm(conmat, matrix(rnorm(20), ncol = 2)),
    "Behavior data must be a numeric vector."
  )
  expect_error(
    cpm(conmat, rnorm(20)),
    "Case numbers of `conmat` and `behav` must match."
  )
  expect_error(
    cpm(conmat, rnorm(10), confounds = matrix(rnorm(20), ncol = 1)),
    "Case numbers of `confounds` and `behav` must match."
  )
})

test_that("`na_action` argument works", {
  withr::local_seed(123)
  conmat <- matrix(rnorm(100), ncol = 10)
  behav <- rnorm(10)
  behav[1] <- NA
  expect_error(cpm(conmat, behav), "Missing values found in `behav`")
  result <- cpm(conmat, behav, na_action = "exclude")
  expect_equal(sum(complete.cases(result$real)), 9)
  expect_equal(sum(complete.cases(result$pred)), 9)
  expect_snapshot(result)
  confounds <- matrix(rnorm(10), ncol = 1)
  confounds[2, 1] <- NA
  result <- cpm(conmat, behav, confounds = confounds, na_action = "exclude")
  expect_equal(sum(complete.cases(result$real)), sum(complete.cases(behav)))
  expect_equal(sum(complete.cases(result$pred)), 8)
  expect_snapshot(result)
  conmat[1, 1] <- NA
  result <- cpm(conmat, behav, confounds = confounds, na_action = "exclude")
  expect_equal(sum(complete.cases(result$real)), sum(complete.cases(behav)))
  expect_equal(sum(complete.cases(result$pred)), 8)
  expect_snapshot(result)
})