tests/testthat/test-predict.R

In mikldk/disclapmix: Discrete Laplace Mixture Inference using the EM Algorithm

test_that("predict", {
  set.seed(1)
  ps_loc <- c(0.3, 0.2, 0.4)
  ps_ys <- c(0.1, 0)
  ys <- matrix(c(13L, 19L, 20L,
                 13L, 20L, 22L), nrow = 2L, byrow = TRUE) # Location parameter 
  tau <- c(0.2, 0.8)
  N <- 1000L
  z <- sample(seq_along(tau), N, prob = tau, replace = TRUE)
  x <- do.call(cbind, lapply(seq_along(ps_loc), function(k) {
    p <- ps_loc[k] + ps_ys[z]
    return(disclap::rdisclap(N, p) + ys[z, k])
  }))
  
  fit <- disclapmix(x = x, clusters = 2L)
  newx <- simulate(fit, nsim = 5L)
  #newx
  #predict(fit, newx)
  
  newx_dropout <- newx
  drop_idx <- sample(seq_len(ncol(newx)), nrow(newx), replace = TRUE)
  for (i in seq_len(nrow(newx_dropout))) {
    newx_dropout[i, drop_idx[i]] <- NA_integer_
  }
  #newx_dropout
  
  expect_error(predict(fit, newx_dropout))

  # Manual marginalisation: One locus
  for (i in seq_len(nrow(newx_dropout))) {
    h <- newx_dropout[i, ]
    ido <- drop_idx[i]
    dh <- do.call(rbind, lapply((-100):100, function(a) {
      hdo <- h
      hdo[ido] <- a
      hdo
    }))
    hm <- newx_dropout[i, , drop = FALSE]
    expect_error(predict(fit, hm))
    ph_marg <- sum(predict(fit, dh))
    ph_do <- predict(fit, hm, marginalise = TRUE)
    stopifnot(isTRUE(all.equal(ph_marg, ph_do)))
  }
  
  # Manual marginalisation: Two locus
  #for (i in seq_len(nrow(x))) {
  for (i in 1:10) {
    dh <- expand.grid(L1 = 15+(-30):30, 
                      L2 = x[i, 2], 
                      L3 = 15+(-30):30) |> 
      as.matrix()
    
    hm <- x[i, , drop = FALSE]
    hm[c(1, 3)] <- NA_integer_
    
    ph_marg <- sum(predict(fit, dh))
    ph_do <- predict(fit, hm, marginalise = TRUE)
    stopifnot(isTRUE(all.equal(ph_marg, ph_do, tolerance = 1e-6)))
  }
})