tests/testthat/test.aldvmm.pred.R

In aldvmm: Adjusted Limited Dependent Variable Mixture Models

test_that('Check prediction function.', {
  
  # Function of tests
  #------------------
  
  test_pred <- function(pred,
                        testdat,
                        psi) {
    testthat::expect(sum(unlist(lapply(pred, 
                                       function(x) sum(!is.numeric(x)) ))) == 0,
                     failure_message = 'Non-numeric elements in predictions.')
    testthat::expect(all(!is.na(pred[["yhat"]])),
                     failure_message = 'Only missing predicted outcomes.')
    testthat::expect(sum(!is.na(pred[["yhat"]])) == sum(complete.cases(testdat)),
                     failure_message = 
                       'Different number of miss. in data & predicted outcomes.')
    testthat::expect(sum(unlist(lapply(pred, 
                                       function(x) (Inf %in% x) | 
                                         (-Inf %in% x)))) == 0,
                     failure_message = 
                       'Predicted outcomes include non-finite values.')
    testthat::expect(all(rowSums(pred[["prob"]]) == 1),
                     failure_message = 
                       "Probabilities of group membership do not sum to 1.")
    
    testthat::expect(all(pred[["yhat"]] <= 1),
                     failure_message = "Predictions larger than one.")
    testthat::expect(all(pred[["yhat"]] >= min(psi)),
                     failure_message = "Predictions smaller than minimum in 
                   'psi'.")
  }
  
  # Two-component model
  #--------------------
  
  testdat <- as.data.frame(matrix(data     = runif(n = 16), 
                                  nrow     = 4, 
                                  ncol     = 4,
                                  dimnames = list(NULL,
                                                  c('dep', 
                                                    'ind1', 
                                                    'ind2', 
                                                    'ind3'))))
  testdat[2, 4] <- NA
  
  ncmp <- 2
  
  names <- c("Grp1_beta_(Intercept)", "Grp1_beta_ind1", "Grp1_beta_ind2", 
             "Grp2_beta_(Intercept)", "Grp2_beta_ind1", "Grp2_beta_ind2", 
             "Grp1_delta_(Intercept)", "Grp1_delta_ind2", "Grp1_delta_ind3", 
             "Grp1_delta_ind2:ind3", "Grp1_sigma", "Grp2_sigma")
  
  mm <- list(beta = rbind('1' = c(1, 0.05933173, 0.4921575),
                          '3' = c(1, 0.059,      0.49),
                          '4' = c(1, 0.05775388, 0.06194975)),
             delta = rbind('1' = c(1, 0.4921575,  0.9556145, 0.4703129),
                           '3' = c(1, 0.5,        0.9,       0.5),
                           '4' = c(1, 0.06194975, 0.1646918, 0.01020262)))  
  
  y <- runif(n = nrow(mm[[1]]))
  
  init <- rep(0, length(names))
  names(init) <- names
  
  psi <- c(0.883, -0.594)
  
  
  
  pred <- aldvmm.pred(par = init,
                      X = mm,
                      y = y,
                      psi = psi,
                      ncmp = 2,
                      dist = 'normal',
                      lcoef = c('beta', 'delta'),
                      lcmp = 'Grp',
                      lcpar = c('sigma'))
  
  
  test_pred(pred = pred,
            testdat = testdat,
            psi = psi)
  
  # Warnings for missing fitted outcomes in two-component model
  #------------------------------------------------------------
  
  inittmp <- rep(-Inf, length(init))
  names(inittmp) <- names(init)
  
  testthat::expect_warning(aldvmm.pred(par = inittmp,
                                       X = mm,
                                       y = y,
                                       psi = psi,
                                       ncmp = 2,
                                       dist = 'normal',
                                       lcoef = c('beta', 'delta'),
                                       lcmp = 'Grp',
                                       lcpar = c('sigma')))
  
  # Warnings for missing predicted probabilities in two-component model
  #--------------------------------------------------------------------
  
  inittmp <- init
  inittmp[grepl("delta",  names(inittmp))] <- Inf
  
  w <- testthat::capture_warnings(  aldvmm.pred(par = inittmp,
                                 X = mm,
                                 y = y,
                                 psi = psi,
                                 ncmp = 2,
                                 dist = 'normal',
                                 lcoef = c('beta', 'delta'),
                                 lcmp = 'Grp',
                                 lcpar = c('sigma'))
  )
  
  testthat::expect_match(w, "fitted probabilities of component membership include missing", all = FALSE)
  testthat::expect_match(w, "fitted values include missing values", all = FALSE)
  
  # Single-component model
  #-----------------------
  
  ncmp <- 1
  
  names <- c("Grp1_beta_(Intercept)", "Grp1_beta_ind1", "Grp1_beta_ind2", 
             "Grp2_beta_(Intercept)", "Grp2_beta_ind1", "Grp2_beta_ind2", 
             "Grp1_delta_(Intercept)", "Grp1_delta_ind2", "Grp1_delta_ind3", 
             "Grp1_delta_ind2:ind3", "Grp1_sigma", "Grp2_sigma")
  
  mm <- list(beta = rbind('1' = c(1, 0.05933173, 0.4921575),
                          '3' = c(1, 0.059,      0.49),
                          '4' = c(1, 0.05775388, 0.06194975)),
             delta = rbind('1' = c(1, 0.4921575,  0.9556145, 0.4703129),
                           '3' = c(1, 0.5,        0.9,       0.5),
                           '4' = c(1, 0.06194975, 0.1646918, 0.01020262)))  
  
  y <- runif(n = nrow(mm[[1]]))
  
  init <- rep(0, length(names))
  names(init) <- names
  
  psi <- c(0.883, -0.594)
  
  pred <- aldvmm.pred(par = init,
                      X = mm,
                      y = y,
                      psi = psi,
                      ncmp = 2,
                      dist = 'normal',
                      lcoef = c('beta', 'delta'),
                      lcmp = 'Grp',
                      lcpar = c('sigma'))
  
  test_pred(pred = pred,
            testdat = testdat,
            psi = psi)
  

})