context("inference") check_cp <- function(x, nrow, colnames) { expect_true(is.numeric(x)) expect_equal(dimnames(x), list(NULL, colnames)) expect_equal(dim(x), c(nrow, length(colnames))) expect_true(are_pdists(x)) } test_that("Complete data set ", { t <- nbcar() a <- compute_cp(x = t, car) check_cp(a, nrow(car), levels(car$class)) }) test_that("Incomplete data set", { # gRain implementation change # skip_if_not_installed('gRain') # t <- nbvote() # a <- compute_cp(x = t, voting) # check_cp(a, nrow(voting), levels(voting$Class)) # gRain implementation change }) test_that("Just the class with incomplete data set", { skip_if_not_installed('gRain') nb <- lp(nb('Class', voting[, 17, drop = FALSE]), voting,smooth = 0) a <- compute_cp(x = nb, voting) check_cp(a, nrow(voting), levels(voting$Class)) cp <- as.vector(params(nb)[[class_var(nb)]]) expect_true(all(apply(a, 1, equivalent_num, cp) )) }) test_that("Single feature with incomplete data", { skip_if_not_installed('gRain') nb <- lp(nb(class = 'Class', v[, c('crime', 'Class'), drop = FALSE]), v, smooth = 0.01) p <- compute_cp(x=nb, v) check_cp(p, nrow(v), levels(v$Class)) }) test_that("No rows returns empty matrix", { skip_if_not_installed('gRain') nb <- nbvote() a <- compute_cp(x=nb, voting[FALSE, ]) check_cp(a, 0L, levels(voting$Class)) }) test_that("Missing features in the dataset", { tn <- nbcar() expect_error(compute_cp(tn, car[, 1:2]), "Some features missing from data set.") }) test_that("Complete with incomplete data", { a <- nbvote() expect_error(compute_log_joint_complete(a, voting), "NA entries in data set.") }) test_that("All incomplete rows", { # gRain implementation change # skip_if_not_installed('gRain') # a <- nbvote() # vna <- voting[!complete.cases(voting), -17] # cp <- compute_log_joint_incomplete(a, vna) # cp <- log_normalize(cp) # cp <- exponentiate_probs(cp) # check_cp(cp, nrow(vna), levels(voting$Class)) # gRain implementation change }) test_that("Incomplete with complete data", { a <- nbcar() expect_error(compute_log_joint_incomplete(a, car), "complete") }) test_that("Uniform for rows with 0 probabilities ", { # some rows have 0 prob nb <- bnc('nb', 'class', car[c(1, 700), ], smooth = 0) p <- compute_cp(x=nb, car[1000:1001, ]) check_cp(p, 2, levels(car$class)) expect_equivalent(rep(0.25, 4), p[1, ]) expect_equivalent(rep(0.25, 4), p[2, ]) # Could be equal to class prior, too. }) test_that("Nominal log-likelihood two vars", { cb <- car[1, c(1, 7), drop = FALSE] nb <- nbcarp(cb) lik <- params(nb)$class['unacc'] * params(nb)$buying['vhigh', 'unacc'] ll <- compute_ll(nb, cb) expect_true(equivalent_num(ll, log(lik))) }) test_that("Nominal conditional log-likelihood two vars", { cb <- car[1, c(1, 7), drop = FALSE] nb <- nbcarp(cb) p <- params(nb)$class * params(nb)$buying['vhigh', ] clik = (p / sum(p) )['unacc'] cll <- compute_cll(nb, cb) expect_true(equivalent_num(cll, log(clik))) }) test_that("log-likelihood with incomplete data", { # gRain implementation change # skip_if_not_installed('gRain') # cb <- car[1, c(1, 7), drop = FALSE] # nb <- nbcarp(cb) # cb$buying[] <- NA_integer_ # ll <- compute_ll(nb, cb) # expect_true(equivalent_num(ll, log(0.4))) # gRain implementation change }) test_that("Nominal log-likelihood 7 vars", { nb <- lp(nb('class', car), car, smooth = 0) ll <- compute_ll(nb, car) expect_equal(ll, -13503.69, tolerance = 1e-6) })