tests/testthat/test-locustable.R

In poppr: Genetic Analysis of Populations with Mixed Reproduction

context("Locus table tests")

data("nancycats", package = "adegenet")
data("Pinf", package = "poppr")
nancy <- popsub(nancycats, c(1, 9))

test_that("locus_table correctly treats polyploids", {
	skip_on_cran()
	pinflt <- locus_table(Pinf)
	pinfpp <- poppr(Pinf, quiet = TRUE)
	expect_equivalent(pinflt[-(nLoc(Pinf) + 1), "allele"], nAll(Pinf) - 1)
	expect_equivalent(pinflt["mean", "Hexp"], pinfpp[pinfpp$Pop == "Total", "Hexp"])
	salt   <- locus_table(Pinf, population = "South America")
	expect_equivalent(salt["Pi33", "allele"], 1)
	expect_equivalent(salt["mean", "Hexp"], pinfpp[pinfpp$Pop == "South America", "Hexp"])
})

test_that("locus_table presents different stats", {
	skip_on_cran()
	randall              <- sample(nLoc(nancy), 1)
	expect_message(nanlt <- locus_table(nancy), "Simpson")
	expect_message(nanlt <- locus_table(nancy, index = "shannon"), "Shannon")
	expect_message(nanlt <- locus_table(nancy, index = "invsimpson"), "Taylor")
	expect_message(nangt <- locus_table(nancy, lev = "genotype"), "genotype")
	expect_gt(nangt[randall, "genotype"], nanlt[randall, "allele"])
	expect_output(nanlt <- locus_table(nancy, information = FALSE), NA)
})

test_that("locus_table will accurately calculate Hexp", {
  skip_on_cran()
  
  # From Kosman, 2003: http://onlinelibrary.wiley.com/doi/10.1046/j.1365-3059.2003.00923.x/full
  qs <- c(2/3, 1, 5/6, 2/3, 1/2, 1/3, 1/6, 1/6)
  hs <- c(4/9, 0, 5/18, 4/9, 1/2, 4/9, 5/18, 5/18)
  
  # Original table, haploid.
  xh <- "
  1 1 1 1 0 0 0 0
  0 1 1 1 1 1 1 0
  1 1 1 1 1 0 0 0
  0 1 1 1 1 1 0 0
  1 1 1 0 0 0 0 0
  1 1 0 0 0 0 0 1"
  xh_tab <- read.table(text = xh, sep = "")
  
  # Double the data, but same result for Hs because of allele frequencies
  xd_tab <- apply(xh_tab, 2, function(x) paste(x + 1, sample(x + 1), sep = "/"))
  xhf <- file()
  xdf <- file()
  write.table(xh_tab + 1, file = xhf, sep = ",")
  write.table(xd_tab, file = xdf, sep = ",")
  x_hap <- pegas::read.loci(xhf, loci.sep = ",")
  x_dip <- pegas::read.loci(xdf, loci.sep = ",", allele.sep = "/")
  close(xhf)
  close(xdf)
  
  lt_hap <- poppr::locus_table(pegas::loci2genind(x_hap))
  lt_dip <- poppr::locus_table(pegas::loci2genind(x_dip))
  
  expect_equivalent(lt_hap[1:8, "1-D"], hs)
  expect_equivalent(lt_dip[1:8, "1-D"], hs)

  expect_equivalent(lt_hap["mean", "1-D"], mean(hs))
  expect_equivalent(lt_dip["mean", "1-D"], mean(hs))
  
  expect_equivalent(lt_hap[1:8, "Hexp"], (6/5)*hs)
  expect_equivalent(lt_dip[1:8, "Hexp"], (12/11)*hs)
  
})