tests/testthat/test-ldfast.R

In ldsep: Linkage Disequilibrium Shrinkage Estimation for Polyploids

test_that("ldfast skips monomorphic sites", {
  set.seed(1)
  n <- 100
  p <- 10
  ploidy <- 4

  ## Generate random data
  gp <- array(stats::runif(n * p * (ploidy + 1)), dim = c(p, n, (ploidy + 1)))
  gp <- sweep(x = gp, MARGIN = c(1, 2), STATS = apply(gp, c(1, 2), sum), FUN = `/`)

  ## Add a couple monomorphic SNPs
  gp[4, , 1] <- 1
  gp[4, , 2] <- 0
  gp[4, , 3] <- 0
  gp[4, , 4] <- 0
  gp[4, , 5] <- 0

  gp[3, , 1] <- 0
  gp[3, , 2] <- 0
  gp[3, , 3] <- 0
  gp[3, , 4] <- 0
  gp[3, , 5] <- 1

  ## Check that everything only produces warnings (due to monomorphic SNPs).
  expect_warning(ldfast(gp = gp, type = "r", upper = 100))
  expect_warning(ldfast(gp = gp, type = "r2", upper = 100))
  expect_warning(ldfast(gp = gp, type = "z", upper = 100))
  expect_warning(ldfast(gp = gp, type = "D", upper = 100))
  expect_warning(ldfast(gp = gp, type = "Dprime", upper = 100))

  ## Check sliding window
  expect_error(ldfast(gp = gp, type = "r", win = 1, se = FALSE, thresh = FALSE, shrinkrr = FALSE), NA)
  expect_error(ldfast(gp = gp, type = "r2", win = 1, se = FALSE, thresh = FALSE, shrinkrr = FALSE), NA)
  expect_error(ldfast(gp = gp, type = "z", win = 1, se = FALSE, thresh = FALSE, shrinkrr = FALSE), NA)
  expect_error(ldfast(gp = gp, type = "D", win = 1, se = FALSE, thresh = FALSE, shrinkrr = FALSE), NA)
  expect_error(ldfast(gp = gp, type = "Dprime", win = 1, se = FALSE, thresh = FALSE, shrinkrr = FALSE), NA)

})


test_that("mycor works", {
  x <- runif(10)
  y <- runif(10)
  x[3:4] <- NA_real_
  y[4:5] <- NA_real_

  expect_equal(
    cor(x, y, use = "pairwise.complete.obs"),
    mycor(x, y)
  )
})

test_that("slcor works", {
  n <- 10
  p <- 100
  xmat <- matrix(rnorm(n * p), ncol = n)
  xmat[sample(n * p, size = 30)] <- NA_real_

  cout <- cor(xmat, use = "pairwise.complete.obs")
  slout <- slcor(xmat)

  which_compare <- !is.na(slout)

  expect_equal(
    cout[which_compare],
    slout[which_compare]
  )
})