Merge pull request #34 from wjakethompson/update-vignettes

Update vignettes

.github/workflows/pkgdown.yaml

@@ -34,6 +34,7 @@ jobs:
             any::pkgdown
             any::tidyverse
             local::.
+          upgrade: 'TRUE'
           needs: website
 
       - name: Build site

.lintr

@@ -1,8 +1,16 @@
-linters: linters_with_defaults()
+linters: linters_with_defaults(
+    indentation_linter = NULL
+  )
 exclusions: list(
     "R/stanmodels.R",
     "R/fit-dcm.R" = list(
       line_length_linter = Inf
+    ),
+    "vignettes/measr.Rmd" = list(
+      commented_code_linter = Inf
+    ),
+    "vignettes/articles/data-raw/example-data.R" = list(
+      object_usage_linter = Inf
     )
   )
 encoding: "UTF-8"

NEWS.md

@@ -2,6 +2,13 @@
 
 * Fixed bug in the LCDM specification of constraints for level-3 and above interaction terms.
 
+* Functions for evaluating estimated models (e.g., `fit_ppmc()`, `reliability()`) no longer recalculate indices if they have previously been saved to the model object. This behavior can be overwritten with `force = TRUE`.
+
+* Updates to documentation
+  * A new article on model evaluation has been added.
+  * The model estimation article has been updated to use the same data set as the model evaluation article.
+  * More detailed installation instructions have been added to the getting started vignette.
+
 # measr 0.3.1
 
 * Added a `NEWS.md` file to track changes to the package.

R/loo-methods.R

@@ -19,13 +19,19 @@ loo::loo_compare
 #' @inheritParams loo::loo
 #' @param x A [measrfit] object.
 #' @param ... Additional arguments passed to [loo::loo.array()].
+#' @param force If the LOO criterion has already been added to the model object
+#'   with [add_criterion()], should it be recalculated. Default is `FALSE`.
 #'
 #' @return The object returned by [loo::loo.array()].
 #'
 #' @export
-loo.measrfit <- function(x, ..., r_eff = NA) { #nolint
+loo.measrfit <- function(x, ..., r_eff = NA, force = FALSE) { #nolint
   model <- check_model(x, required_class = "measrfit", name = "x")
 
+  if (!is.null(model$criteria$loo) && !force) {
+    return(model$criteria$loo)
+  }
+
   if (model$method != "mcmc") {
     rlang::abort("error_bad_method",
                  message = glue::glue("LOO-CV is only available for models ",
@@ -45,13 +51,19 @@ loo.measrfit <- function(x, ..., r_eff = NA) { #nolint
 #'
 #' @param x A [measrfit] object.
 #' @param ... Additional arguments passed to [loo::waic.array()].
+#' @param force If the WAIC criterion has already been added to the model object
+#'   with [add_criterion()], should it be recalculated. Default is `FALSE`.
 #'
 #' @return The object returned by [loo::waic.array()].
 #'
 #' @export
-waic.measrfit <- function(x, ...) { #nolint
+waic.measrfit <- function(x, ..., force = FALSE) { #nolint
   model <- check_model(x, required_class = "measrfit", name = "x")
 
+  if (!is.null(model$criteria$waic) && !force) {
+    return(model$criteria$waic)
+  }
+
   if (model$method != "mcmc") {
     rlang::abort("error_bad_method",
                  message = glue::glue("WAIC is only available for models ",

R/m2-methods.R

@@ -10,6 +10,9 @@ dcm2::fit_m2
 #' described by Hansen et al. (2016) and Liu et al. (2016).
 #'
 #' @inheritParams dcm2::fit_m2
+#' @param force If the \ifelse{html}{\out{M<sub>2</sub>}}{\eqn{M_2}} has already
+#'   been saved to the model object with [add_fit()], should it be recalculated.
+#'   Default is `FALSE`.
 #'
 #' @return A data frame created by [dcm2::fit_m2()].
 #'
@@ -33,10 +36,14 @@ dcm2::fit_m2
 #' )
 #'
 #' fit_m2(rstn_mdm_lcdm)
-fit_m2.measrdcm <- function(model, ci = 0.9, ...) {
+fit_m2.measrdcm <- function(model, ..., ci = 0.9, force = FALSE) {
   model <- check_model(model, required_class = "measrdcm", name = "model")
   ci <- check_double(ci, lb = 0, ub = 1, inclusive = FALSE, name = "ci")
 
+  if (!is.null(model$fit$m2) && !force) {
+    return(model$fit$m2)
+  }
+
   item_order <- levels(model$data$data$item_id)
   dat <- model$data$data %>%
     tidyr::pivot_wider(names_from = "item_id", values_from = "score") %>%

R/model-evaluation.R

@@ -200,6 +200,7 @@ add_fit <- function(x, method = c("m2", "ppmc"), overwrite = FALSE,
   # determine if/which ppmc need to be run
   dots <- list(...)
   run_ppmc <- existing_ppmc_check(model, method, dots, overwrite)
+  run_ppmc$args$force <- TRUE
 
   if (run_m2) {
     model$fit$m2 <- fit_m2(model, ci = ci)

R/ppmc.R

@@ -28,6 +28,8 @@
 #'   Multiple checks can be provided in order to calculate more than one check
 #'   simultaneously (e.g., `item_fit = c("conditional_prob", "odds_ratio")`).
 #'   See details.
+#' @param force If all requested PPMCs have already been added to the model
+#'   object using [add_fit()], should they be recalculated. Default is `FALSE`.
 #'
 #' @details
 #' Posterior predictive model checks (PPMCs) use the posterior distribution of
@@ -102,7 +104,8 @@
 fit_ppmc <- function(model, ndraws = NULL, probs = c(0.025, 0.975),
                      return_draws = 0,
                      model_fit = c("raw_score"),
-                     item_fit = c("conditional_prob", "odds_ratio")) {
+                     item_fit = c("conditional_prob", "odds_ratio"),
+                     force = FALSE) {
   model <- check_model(model, required_class = "measrdcm", name = "object")
   total_draws <- posterior::ndraws(posterior::as_draws(model))
   ndraws <- check_integer(ndraws, lb = 1, ub = total_draws,
@@ -117,6 +120,33 @@ fit_ppmc <- function(model, ndraws = NULL, probs = c(0.025, 0.975),
     rlang::arg_match(item_fit, multiple = TRUE)
   }
 
+  # check for existing fit analyses
+  check_ppmc <- existing_ppmc_check(model = model, method = "ppmc",
+                                    dots = list(ndraws = ndraws,
+                                                probs = probs,
+                                                return_draws = return_draws,
+                                                model_fit = model_fit,
+                                                item_fit = item_fit),
+                                    overwrite = force)
+  if (!check_ppmc$run && !force) {
+    requested <- list(model_fit = model_fit,
+                      item_fit = item_fit)
+    requested[sapply(requested, is.null)] <- NULL
+
+    res <- mapply(
+      function(x, nm, model) {
+        element <- model$fit$ppmc[[nm]][x]
+        rlang::set_names(element, nm = x)
+        return(element)
+      },
+      requested, names(requested),
+      MoreArgs = list(model = model), SIMPLIFY = FALSE, USE.NAMES = TRUE
+    )
+
+    return(res)
+  }
+
+
   if (length(model_fit) == 0 && length(item_fit) == 0) return(list())
 
   clean_qmatrix <- model$data$qmatrix %>%

R/reliability.R

@@ -1,9 +1,13 @@
 #' Estimate the reliability of psychometric models
 #'
 #' @param model The estimated model to be evaluated.
+#' @param ... Unused. For future extensions.
+#' @param force If reliability information has already been added to the model
+#'   object with [add_reliability()], should it be recalculated. Default is
+#'   `FALSE`.
 #'
 #' @export
-reliability <- function(model) {
+reliability <- function(model, ...) {
   UseMethod("reliability")
 }
 
@@ -62,7 +66,12 @@ reliability <- function(model) {
 #' )
 #'
 #' reliability(rstn_mdm_lcdm)
-reliability.measrdcm <- function(model) {
+reliability.measrdcm <- function(model, ..., force = FALSE) {
+  if ((!is.null(model$reliability) && length(model$reliability) > 0) &&
+      !force) {
+    return(model$reliability)
+  }
+
   # coerce model into a list of values required for reliability
   obj <- reli_list(model)
   att_names <- model$data$qmatrix %>%

inst/WORDLIST

@@ -1,7 +1,9 @@
 CDMs
 CMD
 Cai
+CmdStan
 CmdStanModel
+CmdStanR
 Cui
 DCM
 DCMs
@@ -72,13 +74,17 @@ posteriori
 ppp
 pre
 psychometrics
+resave
 rlang
 rstan
 subtype
 subtypes
 tetrachoric
 tibble
 tibbles
+toolchain
 tunnelled
 tunnelling
 warmup
+κ
+λ

pkgdown/_pkgdown.yml

@@ -113,5 +113,7 @@ reference:
 
 news:
   releases:
+  - text: "Version 0.3.1"
+    href: https://www.wjakethompson.com/blog/measr/2023-06-measr-0.3.1/
   - text: "Version 0.2.1"
     href: https://www.wjakethompson.com/blog/measr/2023-04-measr-0.2.1/

tests/testthat/test-m2-methods.R

@@ -59,4 +59,8 @@ test_that("m2 works", {
                dplyr::select(m2, "rmsea", "95% CI"))
   expect_equal(measr_extract(m2_mod, "srmsr"),
                dplyr::select(m2, "srmsr"))
+
+  # recalculating returns same object
+  m2_recalc <- fit_m2(m2_mod)
+  expect_identical(m2_recalc, m2_mod$fit$m2)
 })

tests/testthat/test-mcmc.R

@@ -108,6 +108,9 @@ test_that("loo and waic can be added to model", {
 
   expect_identical(measr_extract(lw_model, "loo"), lw_model$criteria$loo)
   expect_identical(measr_extract(lw_model, "waic"), lw_model$criteria$waic)
+
+  expect_identical(lw_model$criteria$loo, loo(lw_model))
+  expect_identical(lw_model$criteria$waic, waic(lw_model))
 })
 
 test_that("model comparisons work", {
@@ -245,10 +248,13 @@ test_that("model fit can be added", {
   expect_equal(names(test_model$fit$ppmc$item_fit$odds_ratio),
                c("item_1", "item_2", "obs_or", "ppmc_mean", "2.5%", "97.5%",
                  "samples", "ppp"))
+  expect_identical(test_model$fit$ppmc, fit_ppmc(test_model,
+                                                 model_fit = NULL,
+                                                 item_fit = "odds_ratio"))
 
   # nothing new does nothing
   test_model2 <- add_fit(test_model, method = "ppmc", model_fit = NULL,
-                        item_fit = NULL)
+                         item_fit = NULL)
   expect_identical(test_model, test_model2)
 
   # now add ppmc raw score and conditional probs -- other fit should persist

tests/testthat/test-reliability.R

@@ -74,4 +74,6 @@ test_that("reliability can be added to model object", {
                              agreement = "bs"),
                dplyr::select(dina_mod$reliability$eap_reliability,
                              "attribute", informational = "rho_i", "rho_bs"))
+
+  expect_identical(dina_mod$reliability, reliability(dina_mod))
 })

vignettes/.gitignore

@@ -1,2 +1,3 @@
 *.html
 *.R
+articles/*_cache/*