tests/testthat/test-dimensions_missing.R

In logisticPCA: Binary Dimensionality Reduction

context("Missing Dimensions")

# construct a low rank matrix in the logit scale
rows = 100
cols = 10
k = 1
set.seed(2015)
prop_missing = 0.25
mat_logit = outer(rnorm(rows), rnorm(cols))
mat_missing = matrix(runif(rows * cols) <= prop_missing, rows, cols)

mat = (matrix(runif(rows * cols), rows, cols) <= inv.logit.mat(mat_logit)) * 1.0
is.na(mat[mat_missing]) <- TRUE

lpca = logisticPCA(mat, k = k, m = 4, main_effects = FALSE)
lsvd = logisticSVD(mat, k = k, main_effects = FALSE, conv_criteria = 1e-4, partial_decomp = FALSE)
clpca = convexLogisticPCA(mat, m = 4, k = k, main_effects = FALSE)

pred1 = predict(lpca, mat)
pred1l = predict(lpca, mat, type = "link")
pred1r = predict(lpca, mat, type = "response")
fit1l = fitted(lpca, type = "link")
fit1r = fitted(lpca, type = "response")

pred2 = predict(lsvd, mat)
pred2l = predict(lsvd, mat, type = "link")
pred2r = predict(lsvd, mat, type = "response")
fit2l = fitted(lsvd, type = "link")
fit2r = fitted(lsvd, type = "response")

pred3 = predict(clpca, mat)
pred3l = predict(clpca, mat, type = "link")
pred3r = predict(clpca, mat, type = "response")

test_that("correct classes", {
  expect_is(lpca, "lpca")
  expect_is(lsvd, "lsvd")
  expect_is(clpca, "clpca")
  
  expect_is(pred1, "matrix")
  expect_is(pred1l, "matrix")
  expect_is(pred1r, "matrix")
  expect_is(fit1l, "matrix")
  expect_is(fit1r, "matrix")
  
  expect_is(pred2, "matrix")
  expect_is(pred2l, "matrix")
  expect_is(pred2r, "matrix")
  expect_is(fit2l, "matrix")
  expect_is(fit2r, "matrix")
  
  expect_is(pred3, "matrix")
  expect_is(pred3l, "matrix")
  expect_is(pred3r, "matrix")
})

test_that("k = 1 LPCA", {
  expect_equal(dim(lpca$U), c(cols, 1))
  expect_equal(dim(lpca$PCs), c(rows, 1))
  expect_equal(length(lpca$mu), cols)
  
  expect_equal(dim(pred1), c(rows, 1))
  expect_equal(dim(pred1l), c(rows, cols))
  expect_equal(dim(pred1r), c(rows, cols))
  expect_equal(dim(fit1l), c(rows, cols))
  expect_equal(dim(fit1r), c(rows, cols))
})

test_that("k = 1 LSVD", {
  expect_equal(dim(lsvd$B), c(cols, 1))
  expect_equal(dim(lsvd$A), c(rows, 1))
  expect_equal(length(lsvd$mu), cols)
  
  expect_equal(dim(pred2), c(rows, 1))
  expect_equal(dim(pred2l), c(rows, cols))
  expect_equal(dim(pred2r), c(rows, cols))
  expect_equal(dim(fit2l), c(rows, cols))
  expect_equal(dim(fit2r), c(rows, cols))
})

test_that("k = 1 CLPCA", {
  expect_equal(dim(clpca$U), c(cols, 1))
  expect_equal(dim(clpca$H), c(cols, cols))
  expect_equal(dim(clpca$PCs), c(rows, 1))
  expect_equal(length(clpca$mu), cols)
  
  expect_equal(dim(pred3), c(rows, 1))
  expect_equal(dim(pred3l), c(rows, cols))
  expect_equal(dim(pred3r), c(rows, cols))
})


rm(lsvd, lpca, clpca, pred1, pred1l, pred1r, pred2, pred2l, pred2r, 
   pred3, pred3l, pred3r, fit1l, fit1r, fit2l, fit2r)

k = 2
lpca = logisticPCA(mat, m = 4, k = k, main_effects = FALSE)
lsvd = logisticSVD(mat, k = k, main_effects = FALSE, conv_criteria = 1e-4, partial_decomp = FALSE)
clpca = convexLogisticPCA(mat, m = 4, k = k, main_effects = FALSE)

pred1 = predict(lpca, mat)
pred1l = predict(lpca, mat, type = "link")
pred1r = predict(lpca, mat, type = "response")
fit1l = fitted(lpca, type = "link")
fit1r = fitted(lpca, type = "response")

pred2 = predict(lsvd, mat)
pred2l = predict(lsvd, mat, type = "link")
pred2r = predict(lsvd, mat, type = "response")
fit2l = fitted(lsvd, type = "link")
fit2r = fitted(lsvd, type = "response")

pred3 = predict(clpca, mat)
pred3l = predict(clpca, mat, type = "link")
pred3r = predict(clpca, mat, type = "response")

test_that("k = 2 LPCA", {
  expect_equal(dim(lpca$U), c(cols, 2))
  expect_equal(dim(lpca$PCs), c(rows, 2))
  expect_equal(length(lpca$mu), cols)
  
  expect_equal(dim(pred1), c(rows, 2))
  expect_equal(dim(pred1l), c(rows, cols))
  expect_equal(dim(pred1r), c(rows, cols))
  expect_equal(dim(fit1l), c(rows, cols))
  expect_equal(dim(fit1r), c(rows, cols))
})

test_that("k = 2 LSVD", {
  expect_equal(dim(lsvd$B), c(cols, 2))
  expect_equal(dim(lsvd$A), c(rows, 2))
  expect_equal(length(lsvd$mu), cols)
  
  expect_equal(dim(pred2), c(rows, 2))
  expect_equal(dim(pred2l), c(rows, cols))
  expect_equal(dim(pred2r), c(rows, cols))
  expect_equal(dim(fit2l), c(rows, cols))
  expect_equal(dim(fit2r), c(rows, cols))
})

test_that("k = 2 LPCA", {
  expect_equal(dim(clpca$U), c(cols, 2))
  expect_equal(dim(clpca$H), c(cols, cols))
  expect_equal(dim(clpca$PCs), c(rows, 2))
  expect_equal(length(clpca$mu), cols)
  
  expect_equal(dim(pred3), c(rows, 2))
  expect_equal(dim(pred3l), c(rows, cols))
  expect_equal(dim(pred3r), c(rows, cols))
})

test_that("response between 0 and 1", {
  expect_gte(min(pred1r), 0)
  expect_gte(min(fit1r), 0)
  
  expect_lte(max(pred1r), 1)
  expect_lte(max(fit1r), 1)
  
  expect_gte(min(pred2r), 0)
  expect_gte(min(fit2r), 0)
  
  expect_lte(max(pred2r), 1)
  expect_lte(max(fit2r), 1)
  
  expect_gte(min(pred3r), 0)
  expect_lte(max(pred3r), 1)
})