Merge pull request #68 from wjakethompson/air

Add air formatting

Author: wjakethompson

.Rbuildignore

@@ -14,3 +14,5 @@
 ^CRAN-SUBMISSION$
 ^revdep$
 ^CITATION\.cff$
+^[.]?air[.]toml$
+^\.vscode$

.github/workflows/format-suggest.yaml

@@ -0,0 +1,46 @@
+# Workflow derived from https://github.com/posit-dev/setup-air/tree/main/examples
+
+on:
+  # Using `pull_request_target` over `pull_request` for elevated `GITHUB_TOKEN`
+  # privileges, otherwise we can't set `pull-requests: write` when the pull
+  # request comes from a fork, which is our main use case (external contributors).
+  #
+  # `pull_request_target` runs in the context of the target branch (`main`, usually),
+  # rather than in the context of the pull request like `pull_request` does. Due
+  # to this, we must explicitly checkout `ref: ${{ github.event.pull_request.head.sha }}`.
+  # This is typically frowned upon by GitHub, as it exposes you to potentially running
+  # untrusted code in a context where you have elevated privileges, but they explicitly
+  # call out the use case of reformatting and committing back / commenting on the PR
+  # as a situation that should be safe (because we aren't actually running the untrusted
+  # code, we are just treating it as passive data).
+  # https://securitylab.github.com/resources/github-actions-preventing-pwn-requests/
+  pull_request_target:
+
+name: format-suggest.yaml
+
+jobs:
+  format-suggest:
+    name: format-suggest
+    runs-on: ubuntu-latest
+
+    permissions:
+      # Required to push suggestion comments to the PR
+      pull-requests: write
+
+    steps:
+      - uses: actions/checkout@v4
+        with:
+          ref: ${{ github.event.pull_request.head.sha }}
+
+      - name: Install
+        uses: posit-dev/setup-air@v1
+
+      - name: Format
+        run: air format .
+
+      - name: Suggest
+        uses: reviewdog/action-suggester@v1
+        with:
+          level: error
+          fail_level: error
+          tool_name: air

.lintr

@@ -3,6 +3,9 @@ linters: linters_with_defaults(
     return_linter = NULL
   )
 exclusions: list(
+    "data-raw/test-data.R" = list(
+      object_usage_linter = Inf
+    ),
     "R/stanmodels.R",
     "R/import-standalone-obj-type.R",
     "R/import-standalone-types-check.R",

.vscode/extensions.json

@@ -0,0 +1,5 @@
+{
+    "recommendations": [
+        "Posit.air-vscode"
+    ]
+}

.vscode/settings.json

@@ -0,0 +1,10 @@
+{
+    "[r]": {
+        "editor.formatOnSave": true,
+        "editor.defaultFormatter": "Posit.air-vscode"
+    },
+    "[quarto]": {
+        "editor.formatOnSave": true,
+        "editor.defaultFormatter": "quarto.quarto"
+    }
+}

NAMESPACE

@@ -44,6 +44,9 @@ export(measr_dcm)
 export(measr_examples)
 export(measr_extract)
 export(measrdcm)
+export(ncrum)
+export(nida)
+export(nido)
 export(optim)
 export(prior)
 export(reliability)
@@ -76,6 +79,9 @@ importFrom(dcmstan,get_parameters)
 importFrom(dcmstan,hdcm)
 importFrom(dcmstan,independent)
 importFrom(dcmstan,lcdm)
+importFrom(dcmstan,ncrum)
+importFrom(dcmstan,nida)
+importFrom(dcmstan,nido)
 importFrom(dcmstan,prior)
 importFrom(dcmstan,stan_data)
 importFrom(dcmstan,unconstrained)

R/add-model-evaluation.R

@@ -122,12 +122,20 @@ NULL
 
 #' @export
 #' @rdname model_evaluation
-add_criterion <- function(x, criterion = c("loo", "waic", "aic", "bic"),
-                          overwrite = FALSE, save = TRUE, ..., r_eff = NA) {
+add_criterion <- function(
+  x,
+  criterion = c("loo", "waic", "aic", "bic"),
+  overwrite = FALSE,
+  save = TRUE,
+  ...,
+  r_eff = NA
+) {
   rdcmchecks::check_S7(x, class = "measrfit")
-  criterion <- rlang::arg_match(criterion,
-                                values = c("loo", "waic", "aic", "bic"),
-                                multiple = TRUE)
+  criterion <- rlang::arg_match(
+    criterion,
+    values = c("loo", "waic", "aic", "bic"),
+    multiple = TRUE
+  )
   check_bool(overwrite)
   check_bool(save)
 
@@ -181,8 +189,14 @@ add_reliability <- function(x, overwrite = FALSE, save = TRUE, ...) {
 
 #' @export
 #' @rdname model_evaluation
-add_fit <- function(x, method = c("m2", "ppmc"), overwrite = FALSE,
-                    save = TRUE, ..., ci = 0.9) {
+add_fit <- function(
+  x,
+  method = c("m2", "ppmc"),
+  overwrite = FALSE,
+  save = TRUE,
+  ...,
+  ci = 0.9
+) {
   rdcmchecks::check_S7(x, class = "measrfit")
   method <- rlang::arg_match(method, values = c("m2", "ppmc"), multiple = TRUE)
   check_bool(overwrite)
@@ -196,21 +210,20 @@ add_fit <- function(x, method = c("m2", "ppmc"), overwrite = FALSE,
   }
 
   # m2 -------------------------------------------------------------------------
-  if ("m2" %in% method &&
-      (rlang::is_empty(x@fit$m2) || overwrite)) {
+  if ("m2" %in% method && (rlang::is_empty(x@fit$m2) || overwrite)) {
     x@fit$m2 <- fit_m2(x, ci = ci, force = TRUE)
   }
 
   # ppmc -----------------------------------------------------------------------
   if ("ppmc" %in% method) {
     ppmc_list <- fit_ppmc(x, ..., force = overwrite)
     x@fit <- utils::modifyList(x@fit, ppmc_list)
-    x@fit <- lapply(names(x@fit),
-                    \(nm) {
-                      if (!nm %in% names(ppmc_list)) return(x@fit[[nm]])
-                      dplyr::select(x@fit[[nm]],
-                                    dplyr::all_of(names(ppmc_list[[nm]])))
-                    }) |>
+    x@fit <- lapply(names(x@fit), \(nm) {
+      if (!nm %in% names(ppmc_list)) {
+        return(x@fit[[nm]])
+      }
+      dplyr::select(x@fit[[nm]], dplyr::all_of(names(ppmc_list[[nm]])))
+    }) |>
       rlang::set_names(nm = names(x@fit))
   }
 
@@ -223,8 +236,12 @@ add_fit <- function(x, method = c("m2", "ppmc"), overwrite = FALSE,
 
 #' @export
 #' @rdname model_evaluation
-add_respondent_estimates <- function(x, probs = c(0.025, 0.975),
-                                     overwrite = FALSE, save = TRUE) {
+add_respondent_estimates <- function(
+  x,
+  probs = c(0.025, 0.975),
+  overwrite = FALSE,
+  save = TRUE
+) {
   rdcmchecks::check_S7(x, class = "measrfit")
   check_bool(overwrite)
   check_bool(save)
@@ -234,8 +251,12 @@ add_respondent_estimates <- function(x, probs = c(0.025, 0.975),
   }
 
   if (rlang::is_empty(x@respondent_estimates) || overwrite) {
-    x@respondent_estimates <- score(x, summary = TRUE, probs = probs,
-                                    force = TRUE)
+    x@respondent_estimates <- score(
+      x,
+      summary = TRUE,
+      probs = probs,
+      force = TRUE
+    )
   }
 
   # re-save model object (if applicable) ---------------------------------------

R/cdi.R

@@ -66,8 +66,10 @@ cdi <- function(model, weight_prevalence = TRUE) {
       cols = "name",
       patterns = c("pi\\[", item = "[0-9]*", ",", class = "[0-9]*", "\\]")
     ) |>
-    dplyr::mutate(item = as.integer(.data$item),
-                  class = as.integer(.data$class))
+    dplyr::mutate(
+      item = as.integer(.data$item),
+      class = as.integer(.data$class)
+    )
 
   hamming <- profile_hamming(
     dplyr::select(measr_extract(model, "classes"), -"class")
@@ -76,29 +78,42 @@ cdi <- function(model, weight_prevalence = TRUE) {
     dplyr::select(-c("profile_1", "profile_2", "hamming")) |>
     colnames()
 
-  item_discrim <- tidyr::crossing(item = unique(pi_matrix$item),
-                                  profile_1 = unique(pi_matrix$class),
-                                  profile_2 = unique(pi_matrix$class)) |>
-    dplyr::left_join(pi_matrix, by = c("item", "profile_1" = "class"),
-                     relationship = "many-to-one") |>
+  item_discrim <- tidyr::crossing(
+    item = unique(pi_matrix$item),
+    profile_1 = unique(pi_matrix$class),
+    profile_2 = unique(pi_matrix$class)
+  ) |>
+    dplyr::left_join(
+      pi_matrix,
+      by = c("item", "profile_1" = "class"),
+      relationship = "many-to-one"
+    ) |>
     dplyr::rename("prob_1" = "value") |>
-    dplyr::left_join(pi_matrix, by = c("item", "profile_2" = "class"),
-                     relationship = "many-to-one") |>
+    dplyr::left_join(
+      pi_matrix,
+      by = c("item", "profile_2" = "class"),
+      relationship = "many-to-one"
+    ) |>
     dplyr::rename("prob_2" = "value") |>
-    dplyr::mutate(kli = (.data$prob_1 * log(.data$prob_1 / .data$prob_2)) +
-                    ((1 - .data$prob_1) *
-                       log((1 - .data$prob_1) / (1 - .data$prob_2)))) |>
-    dplyr::left_join(hamming, by = c("profile_1", "profile_2"),
-                     relationship = "many-to-one") |>
-    dplyr::mutate(dplyr::across(dplyr::where(is.logical),
-                                \(x) {
-                                  dplyr::case_when(
-                                    x & .data$hamming == 1L ~ TRUE,
-                                    .default = NA
-                                  )
-                                }),
-                  dplyr::across(dplyr::where(is.logical),
-                                \(x) as.integer(x) * .data$kli)) |>
+    dplyr::mutate(
+      kli = (.data$prob_1 * log(.data$prob_1 / .data$prob_2)) +
+        ((1 - .data$prob_1) *
+          log((1 - .data$prob_1) / (1 - .data$prob_2)))
+    ) |>
+    dplyr::left_join(
+      hamming,
+      by = c("profile_1", "profile_2"),
+      relationship = "many-to-one"
+    ) |>
+    dplyr::mutate(
+      dplyr::across(dplyr::where(is.logical), \(x) {
+        dplyr::case_when(
+          x & .data$hamming == 1L ~ TRUE,
+          .default = NA
+        )
+      }),
+      dplyr::across(dplyr::where(is.logical), \(x) as.integer(x) * .data$kli)
+    ) |>
     dplyr::filter(.data$hamming > 0) |>
     dplyr::mutate(weight = 1 / .data$hamming)
 
@@ -135,19 +150,23 @@ cdi <- function(model, weight_prevalence = TRUE) {
   test_discrim <- item_discrim |>
     dplyr::summarize(dplyr::across(-"item", sum))
 
-  list(item_discrimination = item_discrim,
-       test_discrimination = test_discrim)
+  list(item_discrimination = item_discrim, test_discrimination = test_discrim)
 }
 
 profile_hamming <- function(profiles) {
-  profile_combos <- tidyr::crossing(profile_1 = seq_len(nrow(profiles)),
-                                    profile_2 = seq_len(nrow(profiles)))
-
+  profile_combos <- tidyr::crossing(
+    profile_1 = seq_len(nrow(profiles)),
+    profile_2 = seq_len(nrow(profiles))
+  )
 
-  hamming <- mapply(hamming_distance, profile_combos$profile_1,
-                    profile_combos$profile_2,
-                    MoreArgs = list(profiles = profiles),
-                    SIMPLIFY = FALSE, USE.NAMES = FALSE) |>
+  hamming <- mapply(
+    hamming_distance,
+    profile_combos$profile_1,
+    profile_combos$profile_2,
+    MoreArgs = list(profiles = profiles),
+    SIMPLIFY = FALSE,
+    USE.NAMES = FALSE
+  ) |>
     dplyr::bind_rows()
 
   dplyr::bind_cols(profile_combos, hamming)
@@ -158,13 +177,25 @@ hamming_distance <- function(prof1, prof2, profiles) {
   pattern2 <- profiles[prof2, ]
 
   pattern1 |>
-    tidyr::pivot_longer(cols = dplyr::everything(),
-                        names_to = "att", values_to = "patt1") |>
-    dplyr::left_join(tidyr::pivot_longer(pattern2, cols = dplyr::everything(),
-                                         names_to = "att", values_to = "patt2"),
-                     by = "att", relationship = "one-to-one") |>
-    dplyr::mutate(mismatch = .data$patt1 != .data$patt2,
-                  hamming = sum(.data$mismatch)) |>
+    tidyr::pivot_longer(
+      cols = dplyr::everything(),
+      names_to = "att",
+      values_to = "patt1"
+    ) |>
+    dplyr::left_join(
+      tidyr::pivot_longer(
+        pattern2,
+        cols = dplyr::everything(),
+        names_to = "att",
+        values_to = "patt2"
+      ),
+      by = "att",
+      relationship = "one-to-one"
+    ) |>
+    dplyr::mutate(
+      mismatch = .data$patt1 != .data$patt2,
+      hamming = sum(.data$mismatch)
+    ) |>
     dplyr::select("att", "mismatch", "hamming") |>
     tidyr::pivot_wider(names_from = "att", values_from = "mismatch")
 }

R/data-checks.R

@@ -1,14 +1,23 @@
-check_file <- function(x, create_dir = FALSE, check_file = TRUE,
-                       ext = NULL, allow_null = FALSE,
-                       arg = rlang::caller_arg(x),
-                       call = rlang::caller_env()) {
-  if (allow_null && is.null(x)) return(character())
+check_file <- function(
+  x,
+  create_dir = FALSE,
+  check_file = TRUE,
+  ext = NULL,
+  allow_null = FALSE,
+  arg = rlang::caller_arg(x),
+  call = rlang::caller_env()
+) {
+  if (allow_null && is.null(x)) {
+    return(character())
+  }
 
   directory <- fs::path_dir(x)
   if (!fs::dir_exists(directory) && !create_dir) {
-    rdcmchecks::abort_bad_argument(arg = arg,
-                                   must = "be an existing directory",
-                                   call = call)
+    rdcmchecks::abort_bad_argument(
+      arg = arg,
+      must = "be an existing directory",
+      call = call
+    )
   } else if (!fs::dir_exists(directory) && create_dir) {
     fs::dir_create(directory)
   }
@@ -18,9 +27,11 @@ check_file <- function(x, create_dir = FALSE, check_file = TRUE,
   }
 
   if (check_file && !fs::file_exists(x)) {
-    rdcmchecks::abort_bad_argument(arg = arg,
-                                   must = "be an existing file",
-                                   call = call)
+    rdcmchecks::abort_bad_argument(
+      arg = arg,
+      must = "be an existing file",
+      call = call
+    )
   }
 
   return(x)