Merge pull request #9 from wjakethompson/model-fit

Add model fit functionality

.Rbuildignore

@@ -10,3 +10,4 @@
 ^CODE_OF_CONDUCT\.md$
 ^\.github$
 ^cran-comments\.md$
+^vignettes/articles$

.github/workflows/R-CMD-check.yaml

@@ -45,8 +45,8 @@ jobs:
             any::rcmdcheck
             any::BH
             any::RcppEigen
-            url::https://cloud.r-project.org/src/contrib/rstan_2.21.8.tar.gz
-            url::https://cloud.r-project.org/src/contrib/StanHeaders_2.21.0-7.tar.gz
+            url::https://mc-stan.org/r-packages/src/contrib/rstan_2.26.16.tar.gz
+            url::https://mc-stan.org/r-packages/src/contrib/StanHeaders_2.26.16.tar.gz
           needs: check
 
       - name: Install cmdstan

.github/workflows/pkgdown.yaml

@@ -30,7 +30,7 @@ jobs:
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: any::pkgdown, local::.
+          extra-packages: any::pkgdown, any::tidyverse, local::.
           needs: website
 
       - name: Build site

.github/workflows/test-coverage.yaml

@@ -24,8 +24,8 @@ jobs:
         with:
           extra-packages: |
             any::covr
-            url::https://cloud.r-project.org/src/contrib/rstan_2.21.8.tar.gz
-            url::https://cloud.r-project.org/src/contrib/StanHeaders_2.21.0-7.tar.gz
+            url::https://mc-stan.org/r-packages/src/contrib/rstan_2.26.16.tar.gz
+            url::https://mc-stan.org/r-packages/src/contrib/StanHeaders_2.26.16.tar.gz
           needs: coverage
 
       - name: Install cmdstan

.gitignore

@@ -4,3 +4,4 @@
 .httr-oauth
 .DS_Store
 docs
+inst/doc

DESCRIPTION

@@ -6,20 +6,25 @@ Authors@R: c(
            comment = c(ORCID = "0000-0001-7339-0300")),
     person("Nathan", "Jones", , "jonesnateb@gmail.com", role = "ctb",
            comment = c(ORCID = "0000-0001-6177-7161")),
+    person("Matthew", "Johnson", , , role = "cph",
+           comment = "Provided code adapted for reliability.measrdcm()"),
+    person("Paul-Christian", "Bürkner", , , role = "cph",
+           comment = "Author of eval_silent()"),
     person("University of Kansas", role = "cph"),
     person("Institute of Education Sciences", role = "fnd")
   )
 Description: Estimate diagnostic classification models (DCMs; also called
     cognitive diagnostic models [CDMs]) with 'Stan'. Automatically
     generate 'Stan' code for a variety of models, estimate your model, and
     evaluate how well the model fits your data.
-License: MIT + file LICENSE
+License: GPL (>= 3)
 URL: https://measr.info, https://github.com/wjakethompson/measr
 BugReports: https://github.com/wjakethompson/measr/issues
 Depends:
     R (>= 4.1.0)
 Imports:
-    dplyr (>= 1.1.0),
+    dcm2,
+    dplyr (>= 1.1.1),
     fs,
     glue,
     loo,
@@ -36,13 +41,17 @@ Suggests:
     cli,
     cmdstanr (>= 0.4.0),
     crayon,
+    knitr,
+    rmarkdown,
     roxygen2,
     spelling,
     testthat (>= 3.0.0)
-Additional_repositories:https://mc-stan.org/r-packages/
+Additional_repositories: https://mc-stan.org/r-packages/
 Config/testthat/edition: 3
+Config/Needs/website: wjakethompson/wjake, showtext
 Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
+VignetteBuilder: knitr

NAMESPACE

@@ -2,8 +2,10 @@
 
 S3method(as_draws,measrfit)
 S3method(c,measrprior)
+S3method(fit_m2,measrdcm)
 S3method(loo,measrfit)
 S3method(loo_compare,measrfit)
+S3method(measr_extract,measrdcm)
 S3method(predict,measrdcm)
 S3method(prep_loglik_array,measrdcm)
 S3method(reliability,measrdcm)
@@ -12,23 +14,31 @@ export("%>%")
 export(":=")
 export(.data)
 export(add_criterion)
+export(add_fit)
+export(add_reliability)
 export(as_draws)
 export(as_label)
 export(as_name)
 export(create_profiles)
 export(default_dcm_priors)
 export(enquo)
 export(enquos)
+export(fit_m2)
+export(fit_ppmc)
+export(get_parameters)
 export(is.measrprior)
 export(loo)
 export(loo_compare)
 export(measr_dcm)
+export(measr_examples)
+export(measr_extract)
 export(measrprior)
 export(prior)
 export(prior_)
 export(prior_string)
 export(reliability)
 export(waic)
+importFrom(dcm2,fit_m2)
 importFrom(loo,loo)
 importFrom(loo,loo_compare)
 importFrom(loo,waic)

R/data-checks.R

@@ -1,11 +1,15 @@
-abort_bad_argument <- function(arg, must, not = NULL, extra = NULL) {
+abort_bad_argument <- function(arg, must, not = NULL, extra = NULL,
+                               custom = NULL) {
   msg <- glue::glue("`{arg}` must {must}")
   if (!is.null(not)) {
     msg <- glue::glue("{msg}; not {not}")
   }
   if (!is.null(extra)) {
     msg <- glue::glue("{msg}", "{extra}", .sep = "\n")
   }
+  if (!is.null(custom)) {
+    msg <- custom
+  }
 
   rlang::abort("error_bad_argument",
                message = msg,
@@ -39,9 +43,7 @@ check_newdata <- function(x, name, identifier, model, missing) {
     bad_items <- levels(x$item_id)[!(levels(x$item_id) %in% good_items)]
     msg <- paste0("New items found in `newdata`: ",
                   paste(bad_items, collapse = " "))
-    rlang::abort("error_bad_argument",
-                 message = msg,
-                 arg = name)
+    abort_bad_argument(name, must = NULL, custom = msg)
   }
 
   # ensure that factor levels match in original and new data so item parameters
@@ -50,7 +52,8 @@ check_newdata <- function(x, name, identifier, model, missing) {
     dplyr::mutate(
       item_id = as.character(.data$item_id),
       item_id = factor(.data$item_id, levels = levels(model$data$data$item_id))
-    )
+    ) %>%
+    dplyr::arrange(.data$resp_id, .data$item_id)
 
   x
 }
@@ -114,18 +117,38 @@ check_qmatrix <- function(x, identifier, item_levels, name) {
     abort_bad_argument(name, must = "be a data frame")
   }
 
-  if (nrow(x) != length(item_levels)) {
+  if (nrow(x) != length(item_levels) && !is.null(item_levels)) {
     abort_bad_argument(name, must = glue::glue("have the same number of rows ",
                                                "as columns of items in `data`"))
   }
 
   #check that item ids match item levels
-  if (is.null(identifier)) {
+  x <- check_item_levels(x, identifier, item_levels, name)
+
+  if (!all(sapply(dplyr::select(x, -"item_id"), is.numeric))) {
+    abort_bad_argument(name, must = "contain only numeric columns")
+  }
+  x <- dplyr::mutate(x, dplyr::across(-"item_id", as.integer))
+
+  if (!all(sapply(dplyr::select(x, -"item_id"),
+                  function(.x) all(.x %in% c(0L, 1L))))) {
+    abort_bad_argument(name, must = "contain only 0 or 1 in attribute columns")
+  }
+
+  if (!tibble::is_tibble(x)) {
+    tibble::as_tibble(x)
+  } else {
+    x
+  }
+}
+
+check_item_levels <- function(x, identifier, item_levels, name) {
+  if (is.null(identifier) && !is.null(item_levels)) {
     x <- x %>%
       dplyr::mutate(item_id = item_levels,
                     item_id = factor(.data$item_id, levels = item_levels),
                     .before = 1)
-  } else {
+  } else if (!is.null(item_levels)) {
     item_names <- dplyr::pull(x, !!identifier)
     if (!all(item_levels %in% item_names)) {
       abort_bad_argument(
@@ -138,30 +161,28 @@ check_qmatrix <- function(x, identifier, item_levels, name) {
       abort_bad_argument(
         name,
         must = glue::glue("only include items found in `data`.
-                          Extra items: {setdiff(item_names, item_levels)}")
+                          Extra items: {paste(setdiff(item_names, item_levels),
+                                                  collapse = ', ')}")
       )
     }
     x <- x %>%
       dplyr::rename(item_id = !!identifier) %>%
       dplyr::mutate(item_id = factor(.data$item_id, levels = item_levels)) %>%
       dplyr::arrange(.data$item_id)
+  } else if (is.null(identifier) && is.null(item_levels)) {
+    x <- x %>%
+      dplyr::mutate(item_id = seq_len(dplyr::n()),
+                    item_id = factor(.data$item_id, levels = .data$item_id),
+                    .before = 1) %>%
+      dplyr::arrange(.data$item_id)
+  } else if (!is.null(identifier) && is.null(item_levels)) {
+    x <- x %>%
+      dplyr::rename(item_id = !!identifier) %>%
+      dplyr::mutate(item_id = factor(.data$item_id, levels = .data$item_id)) %>%
+      dplyr::arrange(.data$item_id)
   }
 
-  if (!all(sapply(dplyr::select(x, -"item_id"), is.numeric))) {
-    abort_bad_argument(name, must = "contain only numeric columns")
-  }
-  x <- dplyr::mutate(x, dplyr::across(-"item_id", as.integer))
-
-  if (!all(sapply(dplyr::select(x, -"item_id"),
-                  function(.x) all(.x %in% c(0L, 1L))))) {
-    abort_bad_argument(name, must = "contain only 0 or 1 in attribute columns")
-  }
-
-  if (!tibble::is_tibble(x)) {
-    tibble::as_tibble(x)
-  } else {
-    x
-  }
+  return(x)
 }
 
 check_prior <- function(x, name, allow_null = FALSE) {
@@ -212,7 +233,10 @@ check_logical <- function(x, allow_na = FALSE, name) {
   x
 }
 
-check_integer <- function(x, lb = -Inf, ub = Inf, inclusive = TRUE, name) {
+check_integer <- function(x, lb = -Inf, ub = Inf, inclusive = TRUE,
+                          allow_null = FALSE, name) {
+  if (is.null(x) && allow_null) return(x)
+
   if (inclusive) {
     check_lb <- lb
     check_ub <- ub

R/data.R

@@ -44,10 +44,10 @@
 #' contains 28 items measuring 3 skills. The `ecpe_qmatrix` correspondingly is
 #' made up of 28 rows and 4 variables.
 #' * `item_id`: Item identifier, corresponds to `E1`-`E28` in [`ecpe_data`]
-#' * `skill1`-`skill3`: Dichotomous indicator for whether or not the skill is
-#'   measured by each item. A value of `1` indicates the skill is measured by
-#'   the item and a value of `0` indicates the skill is not measured by the
-#'   item.
+#' * `morphosyntactic`, `cohesive`, and `lexical`: Dichotomous indicator for
+#'   whether or not the skill is measured by each item. A value of `1` indicates
+#'   the skill is measured by the item and a value of `0` indicates the skill is
+#'   not measured by the item.
 #' @rdname ecpe
 "ecpe_qmatrix"