tests/testthat/test_NNMF.R

In gdkrmr/dimRed: A Framework for Dimensionality Reduction

skip_if_no_NMF <- function() {
  if (!requireNamespace("NMF", quietly = TRUE) &&
      Sys.getenv("BNET_FORCE_NNMF_TESTS") != "1")
    skip("NMF not available for testing")
}

## if we don't load the library explicitly, the predict function does not work
## (sometimes...).
## library(NMF)

ints_trn <- matrix(seq(0, 98, by = 2), ncol = 5)
input_trn <- dimRedData(as.data.frame(ints_trn))
input_tst <- dimRedData(ints_trn[1:3,] + 1)

test_that("2D projection", {
  skip_if_no_NMF()

  dim_2_defaults <- embed(input_trn, "NNMF", seed = 13, nrun = 1)

  expect_equal(dim_2_defaults@method, "NNMF")

  ## Expected results from
  ## tmp <- NMF::nmf(t(ints_trn), rank = 2, nrun = 1, seed = 13)
  ## coefs <- basis(tmp)
  ## rownames(coefs) <- paste0("V", 1:5)
  ## colnames(coefs) <- paste0("NNMF", 1:2)
  ## coefs
  ## dput(coefs)

  dim_2_coef <- structure(
    c(18.807241710186, 30.2191667888959,
      32.1069052462692, 9.53490906878683,
      164.109205703974, 0.00064246562138093,
      24.3924277525021, 56.4301459918642,
      108.103923297376, 17.566220349863),
    .Dim = c(5L, 2L),
    .Dimnames = list(c("V1", "V2", "V3", "V4", "V5"),
                     c("NNMF1", "NNMF2")))

  expect_equal(dim_2_defaults@other.data$w, dim_2_coef, ignore_attr = TRUE)

  dim_2_apply <- dim_2_defaults@apply(input_tst)@data
  dim_2_pred <- predict(dim_2_defaults, input_tst)@data

  ## Expected results from
  ## t(solve(crossprod(basis(tmp)), t(input_tst@data %*% basis(tmp))))
  ## preds <- getData(input_tst) %*% t(MASS::ginv(basis(tmp)))
  ## getData(getDimRedData(dim_2_defaults))
  ## colnames(preds) <- paste0("NNMF", 1:2)
  ## dput(preds)

  dim_2_exp <- structure(
    c(0.427476458116875, 0.440237021147746, 0.452997584178617,
      0.512256378881175, 0.5332094651398, 0.554162551398426),
    .Dim = c(3L, 2L),
    .Dimnames = list(NULL, c("NNMF1", "NNMF2"))
  )

  expect_equal(dim_2_apply, dim_2_exp, tolerance = 0.01, ignore_attr = TRUE)
  expect_equal(dim_2_pred,  dim_2_exp, tolerance = 0.01, ignore_attr = TRUE)
})

test_that("other arguments", {
  skip_if_no_NMF()

  dim_3_args <- embed(input_trn, "NNMF", seed = 13, nrun = 10,
                      ndim = 3, method = "KL",
                      options = list(.pbackend = NULL))

  ## Expected results from
  ## tmp <- NMF::nmf(t(ints_trn), rank = 3, nrun = 10, seed = 13,
  ##                 method = "KL", .pbackend = NULL)
  ## coefs <- t(NMF::coef(tmp))
  ## colnames(coefs) <- paste0("NNMF", 1:ncol(coefs))
  ## coefs
  ## dput(coefs)
  ## rot <- NMF::basis(tmp)
  ## rownames(rot) <- paste0("V", 1:nrow(rot))
  ## dput(rot)

  dim_3_rot <- structure(
    c(11.624951277152, 31.2554213278975, 50.8858913786408,
      70.5163614293837, 90.1468314801264, 2.22044604925031e-16,
      36.4357899711133, 72.8715799422292, 109.307369913346,
      145.743159884462, 22.4019808842378, 42.1081005773292,
      61.8142202704197, 81.52033996351, 101.2264596566),
    .Dim = c(5L, 3L),
    .Dimnames = list(c("V1", "V2", "V3", "V4", "V5"), NULL)
  )
  dim_3_pred <- structure(
    c(2.22044604925031e-16, 0.0731742704517501, 0.194863499580201,
      0.50224638618713, 0.557517908619563, 0.197219538171418,
      0.0860784848917408, 0.159094934700865, 0.10366866301249,
      0.216483929440989, 0.54891083782883, 0.481738298195276, 0.40204352636632,
      0.274419226004639, 0.211867578024856, 0.256578985276104,
      0.236980211423017, 0.16984840699324, 0.135869049278152,
      0.0584647425861749, 2.22044604925031e-16, 0.0513058500137363,
      0.0774360678481537, 0.00720517673339281, 0.0678012129377125,
      0.344046917890136, 0.49099862480747, 0.542386371921862, 0.660426277478513,
      0.691161417731563),
    .Dim = c(10L, 3L),
    .Dimnames = list(NULL, c("NNMF1", "NNMF2", "NNMF3"))
  )

  expect_equal(dim_3_args@other.data$w, dim_3_rot, ignore_attr = TRUE)
  expect_equal(getData(getDimRedData(dim_3_args)), dim_3_pred, ignore_attr = TRUE)

  dim_3_apply <- dim_3_args@apply(input_tst)@data
  dim_3_pred <- predict(dim_3_args, input_tst)@data

  ## Expected results from
  ## crossprod(basis(tmp)) does not have full rank!!! This needs to be considered
  ## w <- getOtherData(dim_3_args)$w
  ## preds <- t(solve(crossprod(w), t(input_trn@data %*% w)))
  ## preds <- t(qr.solve(crossprod(w), t(input_trn@data %*% w)))
  ## preds <- getData(input_tst) %*% t(MASS::ginv(w))
  ## preds
  ## dput(preds)
  ## getData(getDimRedData(dim_3_args))
  ## preds - getData(getDimRedData(dim_3_args))
  ## input_trn@data
  ## input_tst@data %*% basis(tmp)
  ## colnames(preds) <- paste0("NNMF", 1:3)

  dim_3_exp <- structure(
    c(0.118730450278164, 0.144080695556738, 0.169430940835312,
      0.494122495652466, 0.439293850852014, 0.384465206051563,
      -0.0169733070286198, 0.0591496323928872, 0.135272571814394),
    .Dim = c(3L, 3L)
  )

  expect_equal(dim_3_apply, dim_3_exp, tolerance = 0.01, ignore_attr = TRUE)
  expect_equal(dim_3_pred,  dim_3_exp, tolerance = 0.01, ignore_attr = TRUE)
})


test_that("Bad args", {
  skip_if_no_NMF()

  expect_error(embed(iris, "NNMF"))
  expect_error(embed(iris[, 1], "NNMF"),
               "`ndim` should be less than the number of columns")
  expect_error(embed(iris[1:4], "NNMF", method = c("a", "b")),
               "only supply one `method`")
  expect_error(embed(scale(iris[1:4]), "NNMF"), "negative entries")

})


test_that("Full_rank", {
  skip_if_no_NMF()

  dim_2_full_rank_example <- embed(input_trn, "NNMF", ndim = ncol(input_trn@data))
  dim_2_recon  <- inverse(dim_2_full_rank_example, dim_2_full_rank_example@data@data)

  expect_equal(dim_2_recon, input_trn, ignore_attr = TRUE, tolerance = 1e-2)
})