tests/testthat/test-FStest_RItest.R

In DataSimilarity: Quantifying Similarity of Datasets and Multivariate Two- And k-Sample Testing

testFS <- function(n.iter, new.fun, old.fun, new.opts = NULL, old.opts = NULL) {
  if(requireNamespace("HDLSSkST", quietly = TRUE) & requireNamespace("rmvnorm", quietly = TRUE)) {
    for(i in 1:n.iter) {
      set.seed(i)
      X1 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10),
                             mean = runif(10, -2, 2))
      X2 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X3 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X4 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X5 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X6 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      set.seed(i)
      res.old.perm <- do.call(old.fun, c(list(M = rbind(X1, X2, X3, X4, X5, X6), 
                                              labels = rep(1:6, each = 100), 
                                              sizes = rep(100, 6), 
                                              n_sts = 20), old.opts))
      res.new.perm <- do.call(new.fun, c(list(X1, X2, as.data.frame(X3), X4, X5, X6,
                                              n.perm = 20, seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm, 12)
        testthat::expect_named(res.new.perm, c("statistic",  "p.value", "estimate",
                                               "alternative", "method",  "data.name",
                                               "est.cluster.label", "observed.cont.table",
                                               "crit.value", "random.gamma",       
                                               "decision", "est.cluster.no"))
        # check p values in [0,1]
        testthat::expect_lte(res.new.perm$p.value, 1)
        testthat::expect_gte(res.new.perm$p.value, 0)
        # statistic is not NA
        testthat::expect_false(is.na(res.new.perm$statistic))
        # output should be numeric
        testthat::expect_s3_class(res.new.perm, "htest")
      })
      
      testthat::test_that("output values", {
        # check test statistic values
        testthat::expect_equal(res.new.perm$statistic, res.old.perm$ObservedProb,
                               check.attributes = FALSE)
        # check test p values
        testthat::expect_equal(res.new.perm$p.value, res.old.perm$estPvalue,
                               check.attributes = FALSE)
      })
      
      
      res.new.perm.1 <- do.call(new.fun, c(list(X1[, 1, drop = FALSE], 
                                                X2[, 1, drop = FALSE],
                                                as.data.frame(X3)[, 1, drop = FALSE],
                                                X4[, 1, drop = FALSE], 
                                                X5[, 1, drop = FALSE], 
                                                X6[, 1, drop = FALSE],
                                                n.perm = 20, seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm.1, 12)
        testthat::expect_named(res.new.perm.1, c("statistic",  "p.value", "estimate",
                                                 "alternative", "method",  "data.name",
                                                 "est.cluster.label", "observed.cont.table",
                                                 "crit.value", "random.gamma",       
                                                 "decision", "est.cluster.no"))
        # check p values in [0,1]
        testthat::expect_lte(res.new.perm.1$p.value, 1)
        testthat::expect_gte(res.new.perm.1$p.value, 0)
        # statistic is not NA
        testthat::expect_false(is.na(res.new.perm.1$statistic))
        # output should be numeric
        testthat::expect_s3_class(res.new.perm.1, "htest")
      })
      
      testthat::test_that("NA action", {
        set.seed(i)
        X1.NA <- matrix(rnorm(1000), ncol = 10)
        X2.NA <- matrix(rnorm(1000, mean = 0.5), ncol = 10)
        X1.NA[sample(length(X1.NA), 0.05 * length(X1.NA))] <- NA
        X2.NA[sample(length(X2.NA), 0.01 * length(X2.NA))] <- NA
        
        testthat::expect_no_error(suppressWarnings(new.fun(X1.NA, X2.NA, n.perm = 20, seed = i)))
        testthat::expect_warning(new.fun(X1.NA, X2.NA, n.perm = 20, seed = i))
        testthat::expect_false(suppressWarnings(is.na(new.fun(X1.NA, X2.NA, n.perm = 20, seed = i)$statistic)))
      })  
    }
  }
}

testAFS <- function(n.iter, new.fun, old.fun, new.opts = NULL, old.opts = NULL) {
  if(requireNamespace("HDLSSkST", quietly = TRUE) & requireNamespace("rmvnorm", quietly = TRUE)) {
    for(i in 1:n.iter) {
      set.seed(i)
      X1 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X2 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X3 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X4 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X5 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X6 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      set.seed(i)
      res.old.perm <- do.call(old.fun, c(list(M = rbind(X1, X2, X3, X4, X5, X6),  
                                              sizes = rep(100, 6), 
                                              n_sts = 20), old.opts))
      res.new.perm <- do.call(new.fun, c(list(X1, X2, as.data.frame(X3), X4, X5, X6, 
                                              n.perm = 20, seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm, 10)
        testthat::expect_named(res.new.perm, c('statistic', 'p.value', 'estimate', 
                                               'alternative', 'method', 'data.name', 
                                               'crit.value', 'random.gamma', 
                                               'decision', 'est.cluster.no'))
        # statistic is not NA
        testthat::expect_false(is.na(res.new.perm$statistic))
        # output should be numeric
        testthat::expect_s3_class(res.new.perm, "htest")
      })
      
      testthat::test_that("output values", {
        # check test statistic values
        testthat::expect_equal(res.new.perm$statistic, res.old.perm$AFSStat,
                               check.attributes = FALSE)
        # check test p values
        testthat::expect_equal(res.new.perm$est.cluster.no, res.old.perm$multipleTest,
                               check.attributes = FALSE)
      })
      
      # not working for p = 1
      testthat::test_that("NA action", {
        set.seed(i)
        X1.NA <- matrix(rnorm(1000), ncol = 10)
        X2.NA <- matrix(rnorm(1000, mean = 0.5), ncol = 10)
        X1.NA[sample(length(X1.NA), 0.05 * length(X1.NA))] <- NA
        X2.NA[sample(length(X2.NA), 0.01 * length(X2.NA))] <- NA
        
        testthat::expect_no_error(suppressWarnings(do.call(new.fun, c(list(X1.NA, X2.NA, 
                                                            n.perm = 20, seed = i), new.opts))))
        testthat::expect_warning(do.call(new.fun, c(list(X1.NA, X2.NA, n.perm = 20, 
                                                         seed = i), new.opts)))
        testthat::expect_false(suppressWarnings(is.na(do.call(new.fun, c(list(X1.NA, X2.NA, 
                                                        n.perm = 20, seed = i), new.opts))$statistic)))
      }) 
    }
  }
}

testMSFS <- function(n.iter, new.fun, old.fun, new.opts = NULL, old.opts = NULL) {
  if(requireNamespace("HDLSSkST", quietly = TRUE) & requireNamespace("rmvnorm", quietly = TRUE)) {
    for(i in 1:n.iter) {
      set.seed(i)
      X1 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X2 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X3 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), 
                             mean = runif(10, -2, 2))
      X4 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2),
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X5 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10),
                             mean = runif(10, -2, 2))
      X6 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), 
                             sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      set.seed(i)
      res.old.perm <- do.call(old.fun, c(list(M = rbind(X1, X2, X3, X4, X5, X6),  
                                              labels = rep(1:6, each = 100), 
                                              sizes = rep(100, 6),  
                                              n_sts = 20), old.opts))
      res.new.perm <- do.call(new.fun, c(list(X1, X2, as.data.frame(X3), X4, X5, X6, 
                                              n.perm = 20, seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm, 9)
        testthat::expect_named(res.new.perm, c('statistic', 'p.value', 'estimate', 
                                               'alternative', 'method', 'data.name', 
                                               'observed.cont.table', 'decision', 
                                               'decision.per.k'))
        # statistic is not NA
        testthat::expect_false(any(is.na(res.new.perm$statistic)))
        testthat::expect_false(any(is.na(res.new.perm$p.value)))
      })
      
      testthat::test_that("output values", {
        # check test statistic values
        testthat::expect_equal(res.new.perm$statistic, res.old.perm$fpmfvec,
                               check.attributes = FALSE)
        # check test p values
        testthat::expect_equal(res.new.perm$p.value, res.old.perm$Pvalues,
                               check.attributes = FALSE)
      })
      
      res.new.perm.1 <- do.call(new.fun, c(list(X1[, 1, drop = FALSE], 
                                                X2[, 1, drop = FALSE], 
                                                as.data.frame(X3)[, 1, drop = FALSE], 
                                                X4[, 1, drop = FALSE], 
                                                X5[, 1, drop = FALSE], 
                                                X6[, 1, drop = FALSE], 
                                                n.perm = 20, seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm.1, 9)
        testthat::expect_named(res.new.perm.1, c('statistic', 'p.value', 'estimate', 
                                                 'alternative', 'method', 'data.name', 
                                                 'observed.cont.table', 'decision', 
                                                 'decision.per.k'))
        # statistic is not NA
        testthat::expect_false(any(is.na(res.new.perm.1$statistic)))
        testthat::expect_false(any(is.na(res.new.perm.1$p.value)))
      })
      
      testthat::test_that("NA action", {
        set.seed(i)
        X1.NA <- matrix(rnorm(1000), ncol = 10)
        X2.NA <- matrix(rnorm(1000, mean = 0.5), ncol = 10)
        X1.NA[sample(length(X1.NA), 0.05 * length(X1.NA))] <- NA
        X2.NA[sample(length(X2.NA), 0.01 * length(X2.NA))] <- NA
        
        testthat::expect_no_error(suppressWarnings(do.call(new.fun, c(list(X1.NA, X2.NA, 
                                                            n.perm = 20, seed = i), new.opts))))
        testthat::expect_warning(do.call(new.fun, c(list(X1.NA, X2.NA, n.perm = 20, 
                                                         seed = i), new.opts)))
        testthat::expect_false(suppressWarnings(anyNA(do.call(new.fun, c(list(X1.NA, X2.NA, 
                                                               n.perm = 20, seed = i), new.opts))$statistic)))
      }) 
    }
  }
}

# original
set.seed(0305)
testFS(1, DataSimilarity::FStest, HDLSSkST::FStest, old.opts = list(n_clust = 6, s.psi = 3))

# modified
set.seed(0305)
testFS(1, DataSimilarity::FStest, HDLSSkST::FStest, new.opts = list(version = "modified"), 
       old.opts = list(clust_alg = "estClustNo", n_clust = 6, s.psi = 3))

# multiscale
set.seed(0305)
testMSFS(1, DataSimilarity::FStest, HDLSSkST::MTFStest, new.opts = list(version = "multiscale"), 
         old.opts = list(k_max = 12, s.psi = 3))

# aggregated
set.seed(0305)
testAFS(1, DataSimilarity::FStest, HDLSSkST::AFStest, new.opts = list(version = "aggregated-knw"), 
        old.opts = list(s.psi = 3))


set.seed(0305)
testAFS(1, DataSimilarity::FStest, HDLSSkST::AFStest, new.opts = list(version = "aggregated-est"), 
        old.opts = list(clust_alg = "estClustNo", s.psi = 3))


testRI <- function(n.iter, new.fun, old.fun, new.opts = NULL, old.opts = NULL) {
  if(requireNamespace("HDLSSkST", quietly = TRUE) & requireNamespace("rmvnorm", quietly = TRUE)) {
    for(i in 1:n.iter) {
      set.seed(i)
      X1 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), mean = runif(10, -2, 2))
      X2 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X3 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), mean = runif(10, -2, 2))
      X4 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X5 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), mean = runif(10, -2, 2))
      X6 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      set.seed(i)
      res.old.perm <- do.call(old.fun, c(list(M = rbind(X1, X2, X3, X4, X5, X6), 
                                              labels = rep(1:6, each = 100), 
                                              sizes = rep(100, 6), 
                                              n_sts = 20), old.opts))
      res.new.perm <- do.call(new.fun, c(list(X1, X2, X3, X4, X5, X6, n.perm = 20, 
                                              seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm, 12)
        testthat::expect_named(res.new.perm, c("statistic",  "p.value", "estimate",
                                               "alternative", "method",  "data.name",
                                               "est.cluster.label", "observed.cont.table",
                                               "crit.value", "random.gamma",       
                                               "decision", "est.cluster.no"))
        # check p values in [0,1]
        testthat::expect_lte(res.new.perm$p.value, 1)
        testthat::expect_gte(res.new.perm$p.value, 0)
        # statistic is not NA
        testthat::expect_false(is.na(res.new.perm$statistic))
        # output should be numeric
        testthat::expect_s3_class(res.new.perm, "htest")
      })
      
      testthat::test_that("output values", {
        # check test statistic values
        testthat::expect_equal(res.new.perm$statistic, res.old.perm$ObservedRI,
                               check.attributes = FALSE)
        # check test p values
        testthat::expect_equal(res.new.perm$p.value, res.old.perm$estPvalue,
                               check.attributes = FALSE)
      })
      
      testthat::test_that("NA action", {
        set.seed(i)
        X1.NA <- matrix(rnorm(1000), ncol = 10)
        X2.NA <- matrix(rnorm(1000, mean = 0.5), ncol = 10)
        X1.NA[sample(length(X1.NA), 0.05 * length(X1.NA))] <- NA
        X2.NA[sample(length(X2.NA), 0.01 * length(X2.NA))] <- NA
        
        testthat::expect_no_error(suppressWarnings(new.fun(X1.NA, X2.NA, n.perm = 20, seed = i)))
        testthat::expect_warning(new.fun(X1.NA, X2.NA, n.perm = 20, seed = i))
        testthat::expect_false(suppressWarnings(is.na(new.fun(X1.NA, X2.NA, n.perm = 20, seed = i)$statistic)))
      }) 
    }
  }
}

testARI <- function(n.iter, new.fun, old.fun, new.opts = NULL, old.opts = NULL) {
  if(requireNamespace("HDLSSkST", quietly = TRUE) & requireNamespace("rmvnorm", quietly = TRUE)) {
    for(i in 1:n.iter) {
      set.seed(i)
      X1 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), mean = runif(10, -2, 2))
      X2 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X3 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), mean = runif(10, -2, 2))
      X4 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      X5 <- mvtnorm::rmvnorm(100, sigma = matrix(0.2, 10, 10) + diag(0.8, 10, 10), mean = runif(10, -2, 2))
      X6 <- mvtnorm::rmvnorm(100, mean = runif(10, -2, 2), sigma = matrix(0.5, 10, 10) + diag(0.5, 10, 10))
      set.seed(i)
      res.old.perm <- do.call(old.fun, c(list(M = rbind(X1, X2, X3, X4, X5, X6),  
                                              sizes = rep(100, 6), 
                                              n_sts = 20), old.opts))
      res.new.perm <- do.call(new.fun, c(list(X1, X2, X3, X4, X5, X6, n.perm = 20, 
                                              seed = i), new.opts))
      
      testthat::test_that("output type", {
        # check length and names of output
        testthat::expect_length(res.new.perm, 10)
        testthat::expect_named(res.new.perm, c('statistic', 'p.value', 'estimate', 
                                               'alternative', 'method', 'data.name', 
                                               'crit.value', 'random.gamma', 
                                               'decision', 'est.cluster.no'))
        # statistic is not NA
        testthat::expect_false(is.na(res.new.perm$statistic))
        # output should be numeric
        testthat::expect_s3_class(res.new.perm, "htest")
      })
      
      testthat::test_that("output values", {
        # check test statistic values
        testthat::expect_equal(res.new.perm$statistic, res.old.perm$ARIStat,
                               check.attributes = FALSE)
        # check test p values
        testthat::expect_equal(res.new.perm$est.cluster.no, res.old.perm$multipleTest,
                               check.attributes = FALSE)
      })
      
      testthat::test_that("NA action", {
        set.seed(i)
        X1.NA <- matrix(rnorm(1000), ncol = 10)
        X2.NA <- matrix(rnorm(1000, mean = 0.5), ncol = 10)
        X1.NA[sample(length(X1.NA), 0.05 * length(X1.NA))] <- NA
        X2.NA[sample(length(X2.NA), 0.01 * length(X2.NA))] <- NA
        
        testthat::expect_no_error(suppressWarnings(do.call(new.fun, c(list(X1.NA, X2.NA, 
                                                            n.perm = 20, seed = i), new.opts))))
        testthat::expect_warning(do.call(new.fun, c(list(X1.NA, X2.NA, n.perm = 20, 
                                                         seed = i), new.opts)))
        testthat::expect_false(suppressWarnings(is.na(do.call(new.fun, c(list(X1.NA, X2.NA, 
                                                        n.perm = 20, seed = i), new.opts))$statistic)))
      }) 
    }
  }
}

# original
set.seed(0305)
testRI(1, DataSimilarity::RItest, HDLSSkST::RItest, old.opts = list(n_clust = 6, s.psi = 3))

# modified
set.seed(0305)
testRI(1, DataSimilarity::RItest, HDLSSkST::RItest, new.opts = list(version = "modified"), 
       old.opts = list(clust_alg = "estClustNo", n_clust = 6, s.psi = 3))

# multiscale

# aggregated
set.seed(0305)
testARI(1, DataSimilarity::RItest, HDLSSkST::ARItest, new.opts = list(version = "aggregated-knw"), 
        old.opts = list(s.psi = 3))


set.seed(0305)
testARI(1, DataSimilarity::RItest, HDLSSkST::ARItest, new.opts = list(version = "aggregated-est"), 
        old.opts = list(clust_alg = "estClustNo", s.psi = 3))