add extractor for overall p-value

Author: wjakethompson

R/extract.R

@@ -77,6 +77,10 @@ measr_extract <- function(model, ...) {
 #'     Model fit information must first be added to the model using [add_fit()].
 #'   * `ppmc_odds_ratio_flags`: A subset of the PPMC odds ratios where the _ppp_
 #'     is outside the specified `ppmc_interval`.
+#'   * `ppmc_pvalue`: The observed and posterior predicted proportion of correct
+#'     responses to each item. See [fit_ppmc()] for details.
+#'   * `ppmc_pvalue_flags`: A subset of the PPMC proportion correct values where
+#'     the _ppp_ is outside the specified `ppmc_interval`.
 #'   * `loo`: The leave-one-out cross validation results. See [loo::loo()] for
 #'     details. The information criterion must first be added to the model using
 #'     [add_criterion()].
@@ -146,6 +150,8 @@ measr_extract.measrdcm <- function(model, what, ...) {
     ppmc_conditional_prob_flags = dcm_extract_ppmc_cond_prob(model, ...),
     ppmc_odds_ratio = extract_or(model, ppmc_interval = NULL),
     ppmc_odds_ratio_flags = extract_or(model, ...),
+    ppmc_pvalue = dcm_extract_ppmc_pvalue(model, ppmc_interval = NULL),
+    ppmc_pvalue_flags = dcm_extract_ppmc_pvalue(model, ...),
     loo = extract_info_crit(model, "loo"),
     waic = extract_info_crit(model, "waic"),
     pattern_reliability = dcm_extract_patt_reli(model),

R/utils-extract.R

@@ -187,6 +187,31 @@ dcm_extract_ppmc_cond_prob <- function(model, ppmc_interval = 0.95) {
   return(res)
 }
 
+dcm_extract_ppmc_pvalue <- function(model, ppmc_interval = 0.95) {
+  if (!is.null(ppmc_interval)) {
+    ppmc_interval <- check_double(ppmc_interval, lb = 0, ub = 1,
+                                  name = "ppmc_interval")
+  }
+
+  if (is.null(model$fit$ppmc$item_fit$pvalue)) {
+    rlang::abort(message = glue::glue("Model fit information must be ",
+                                      "added to a model object before ",
+                                      "p-values can be ",
+                                      "extracted. See `?add_fit()`."))
+  }
+
+  res <- if (is.null(ppmc_interval)) {
+    model$fit$ppmc$item_fit$pvalue
+  } else {
+    model$fit$ppmc$item_fit$pvalue %>%
+      dplyr::filter(!dplyr::between(.data$ppp,
+                                    (1 - ppmc_interval) / 2,
+                                    1 - ((1 - ppmc_interval) / 2)))
+  }
+
+  return(res)
+}
+
 dcm_extract_patt_reli <- function(model) {
   if (identical(model$reliability, list())) {
     rlang::abort(message = glue::glue("Reliability information must be ",