Add loglik tests

13 files changed, 89 insertions, 1 deletions

diff --git a/DESCRIPTION b/DESCRIPTION
index 5b2ce8c..6720287 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: ubms
 Version: 1.1.9003
-Date: 2022-03-31
+Date: 2022-04-11
 Title: Bayesian Models for Data from Unmarked Animals using 'Stan'
 Authors@R: person("Ken", "Kellner", email="contact@kenkellner.com", 
                   role=c("cre","aut"))
diff --git a/R/kfold.R b/R/kfold.R
index 97ea675..9f54cd5 100644
--- a/R/kfold.R
+++ b/R/kfold.R
@@ -1,5 +1,10 @@
 #' K-fold Cross-validation of a ubmsFit Model
 #'
+#' Randomly partition data into K subsets of equal size (by site). Re-fit the model
+#' K times, each time leaving out one of the subsets. Calculate the log-likelihood
+#' for each of the sites that was left out. This function is an alternative
+#' to \code{loo} (leave-one-out cross validation).
+#'
 #' @param x A \code{ubmsFit} model
 #' @param K Number of folds into which the data will be partitioned
 #' @param folds An optional vector with length equal to the number of sites in the data and containing integers from 1 to K, to manually assign sites to folds. You should use this if you plan to compare multiple models, since the folds for each model should be identical. You can use \code{loo::kfold_split_random} to generate this vector
diff --git a/R/loglik.R b/R/loglik.R
index b638006..ef4dc71 100644
--- a/R/loglik.R
+++ b/R/loglik.R
@@ -1,6 +1,7 @@
 # Calculate parameter from X, Z, offset
 # Can't use posterior_linpred for this because it doesn't drop NAs
 # Inps are output from get_stan_inputs()
+# Right now the permute argument isn't used
 calculate_par <- function(object, inps, submodel, permute=FALSE){
   X <- inps$stan_data[[paste0("X_",submodel)]]
   beta <- extract_posterior(object, paste0("beta_", submodel))
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 748f0ca..1625f2d 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -20,6 +20,7 @@ reference:
   - title: Model selection
     contents:
       - fitList
+      - kfold,ubmsFit-method
       - loo,ubmsFit-method
       - modSel,ubmsFitList-method
       - waic,ubmsFit-method
diff --git a/tests/testthat/test_colext.R b/tests/testthat/test_colext.R
index 618714c..4882a6e 100644
--- a/tests/testthat/test_colext.R
+++ b/tests/testthat/test_colext.R
@@ -82,6 +82,13 @@ test_that("stan_colext handles NA values",{
   expect_RMSE(coef(fit_na), coef(fit), 1.5)
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(100/2 * 2, numSites(fit@data))) 
+  expect_between(sum(ll), -5700, -5500) 
+})
+
 test_that("ubmsFitColext gof method works",{
   set.seed(123)
   g <- gof(fit, draws=5, quiet=TRUE)
diff --git a/tests/testthat/test_distsamp.R b/tests/testthat/test_distsamp.R
index 8a8c22a..b875be3 100644
--- a/tests/testthat/test_distsamp.R
+++ b/tests/testthat/test_distsamp.R
@@ -121,6 +121,13 @@ test_that("stan_distsamp handles NA values",{
   expect_error(stan_distsamp(~1~1, ltUMF_na))
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit_pt_hn)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(200/2 * 2, numSites(fit_pt_hn@data))) 
+  expect_between(sum(ll), -39000, -38000) 
+})
+
 test_that("ubmsFitDistsamp gof method works",{
   set.seed(123)
   g <- lapply(line_mods, function(x) gof(x, draws=5, quiet=TRUE))
diff --git a/tests/testthat/test_multinomPois.R b/tests/testthat/test_multinomPois.R
index 6959786..c9bb896 100644
--- a/tests/testthat/test_multinomPois.R
+++ b/tests/testthat/test_multinomPois.R
@@ -96,6 +96,13 @@ test_that("stan_multinomPois handles NA values",{
   expect_is(coef(fit_rem_na), "numeric")
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit_double)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(100/2 * 2, numSites(fit_double@data))) 
+  expect_between(sum(ll), -5000, -4600) 
+})
+
 test_that("ubmsFitMultinomPois gof method works",{ ##here
   set.seed(123)
   g <- gof(fit_double, draws=5, quiet=TRUE)
diff --git a/tests/testthat/test_occu.R b/tests/testthat/test_occu.R
index bc6efbd..8a45953 100644
--- a/tests/testthat/test_occu.R
+++ b/tests/testthat/test_occu.R
@@ -68,6 +68,13 @@ test_that("stan_occu handles NA values",{
   expect_RMSE(coef(fit), coef(fit_na), 2)
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(100/2 * 2, numSites(fit@data))) 
+  expect_between(sum(ll), -3500, -3200) 
+})
+
 test_that("ubmsFitOccu gof method works",{
   set.seed(123)
   g <- gof(fit, draws=5, quiet=TRUE)
diff --git a/tests/testthat/test_occuRN.R b/tests/testthat/test_occuRN.R
index 1c6ae39..5d01b90 100644
--- a/tests/testthat/test_occuRN.R
+++ b/tests/testthat/test_occuRN.R
@@ -68,6 +68,13 @@ test_that("stan_occuRN handles NA values",{
   expect_is(coef(fit_na), "numeric")
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(100/2 * 2, numSites(fit@data))) 
+  expect_between(sum(ll), -3000, -2700) 
+})
+
 test_that("ubmsFitOccuRN gof method works",{
   set.seed(123)
   g <- gof(fit, draws=5, quiet=TRUE)
diff --git a/tests/testthat/test_occuTTD.R b/tests/testthat/test_occuTTD.R
index a36a77b..1eff257 100644
--- a/tests/testthat/test_occuTTD.R
+++ b/tests/testthat/test_occuTTD.R
@@ -85,6 +85,13 @@ test_that("stan_occuTTD handles NA values",{
   expect_is(coef(fit_na), "numeric")
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(100/2 * 2, numSites(fit@data))) 
+  expect_between(sum(ll), -700, -400) 
+})
+
 test_that("ubmsFitOccuTTD gof method gives error",{
   expect_error(gof(fit, draws=5, quiet=TRUE))
 })
diff --git a/tests/testthat/test_pcount.R b/tests/testthat/test_pcount.R
index 32b0710..f0dc013 100644
--- a/tests/testthat/test_pcount.R
+++ b/tests/testthat/test_pcount.R
@@ -84,6 +84,13 @@ test_that("stan_pcount handles NA values",{
   expect_true(is.numeric(coef(fit_na)))
 })
 
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(100/2 * 2, numSites(fit@data))) 
+  expect_between(sum(ll), -7000, -6000) 
+})
+
 test_that("ubmsFitPcount gof method works",{
   set.seed(123)
   g <- gof(fit, draws=5, quiet=TRUE)
diff --git a/tests/testthat/test_spatial.R b/tests/testthat/test_spatial.R
index bb1f33f..07ffc91 100644
--- a/tests/testthat/test_spatial.R
+++ b/tests/testthat/test_spatial.R
@@ -197,3 +197,10 @@ test_that("plot_spatial returns ggplot", {
   expect_error(plot_spatial(umf))
   expect_error(plot_spatial(fit2))
 })
+
+test_that("extract_log_lik method works",{
+  ll <- extract_log_lik(fit)
+  expect_is(ll, "matrix")
+  expect_equal(dim(ll), c(200/2 * 2, numSites(fit@data)-7)) 
+  expect_between(sum(ll), -7000, -6500) 
+})
diff --git a/tests/testthat/test_ubmsFit_methods.R b/tests/testthat/test_ubmsFit_methods.R
index c5974d5..8a66f87 100644
--- a/tests/testthat/test_ubmsFit_methods.R
+++ b/tests/testthat/test_ubmsFit_methods.R
@@ -158,3 +158,28 @@ test_that("get_stancode method works",{
   out <- get_stancode(fit)
   expect_is(out, "character")
 })
+
+test_that("rebuild_inputs can get Stan inputs from fitted model",{
+  inps <- rebuild_inputs(fit)
+  cl <- fit@call
+  cl$return_inputs <- TRUE
+  refit <- eval(cl)
+  expect_equal(names(inps), c("stan_data", "pars", "submodels"))
+  expect_equal(inps, refit)
+})
+
+# Functions in loglik.R
+test_that("calculate_par works",{
+  inps <- rebuild_inputs(fit)
+  cp <- calculate_par(fit, inps, 'state')
+  expect_equal(dim(cp), c(3,40)) 
+  cp_mean <- apply(cp, 1, mean)
+  pr <- predict(fit, 'state')
+  expect_equivalent(cp_mean, pr$Predicted)
+})
+
+test_that("extract_posterior works",{  
+  post <- extract_posterior(fit, 'beta_state')
+  expect_is(post, "matrix")
+  expect_equal(dim(post), c(40, 2))
+})