Split lms linters into one file each and match expectation arguments as R does

lms/DESCRIPTION

@@ -1,6 +1,6 @@
 Package: lms
 Title: Lab Manual Style (UCD-SERG lintr Configuration)
-Version: 0.1.1
+Version: 0.1.2
 Authors@R:
     person("UCD-SERG", role = c("aut", "cre"), email = "serg@ucdavis.edu")
 Description: Shared lintr linter configuration implementing the UCD-SERG

lms/R/call_arg_slots.R

@@ -0,0 +1,44 @@
+#' Split a call's arguments into slots
+#'
+#' Walks the children of a call's `expr` node in lintr's XML parse tree,
+#' between its parentheses, and splits them at each `OP-COMMA`.
+#' Comments are skipped.
+#' A slot is named when it holds `EQ_SUB`;
+#' the name drops surrounding backticks or quotes,
+#' so `` `class` = x `` and `"class" = x` both name `class`.
+#'
+#' @param call The call's `expr` node in lintr's XML parse tree.
+#' @return A list with one element per argument slot, each a list with
+#'   `name` (the argument name, or `NA` when unnamed) and
+#'   `text` (the argument value's source text, `""` for an empty argument).
+#' @noRd
+call_arg_slots <- function(call) {
+  children <- xml2::xml_children(call)
+  kinds <- xml2::xml_name(children)
+  inside <- seq_along(kinds) > match("OP-LEFT-PAREN", kinds) &
+    seq_along(kinds) < length(kinds) &
+    kinds != "COMMENT"
+  args <- children[inside]
+  arg_kinds <- kinds[inside]
+  if (!length(args)) {
+    return(list())
+  }
+
+  # A factor keeps an empty slot (such as the first in `f(, x)`), which
+  # would otherwise have no elements and be dropped by split().
+  slot_id <- cumsum(arg_kinds == "OP-COMMA")
+  slot_id <- factor(slot_id, levels = 0:max(slot_id))
+  lapply(split(seq_along(args), slot_id), function(idx) {
+    idx <- idx[arg_kinds[idx] != "OP-COMMA"]
+    eq <- which(arg_kinds[idx] == "EQ_SUB")
+    if (length(eq)) {
+      name <- gsub("^[`'\"]|[`'\"]$", "", xml2::xml_text(args[[idx[1]]]))
+      value <- idx[-seq_len(eq[1])]
+    } else {
+      name <- NA_character_
+      value <- idx
+    }
+    text <- paste(xml2::xml_text(args[value]), collapse = "")
+    list(name = name, text = text)
+  })
+}

lms/R/condition_class_linter.R

@@ -1,8 +1,10 @@
 #' Condition-class linter for testthat expectations
 #'
 #' Flags `expect_error()`, `expect_warning()`, and `expect_message()` calls
-#' that assert on message text (`regexp =` or positional `regexp`) without
-#' also asserting on a condition `class =`.
+#' that assert on message text (`regexp`) without
+#' also asserting on a condition `class`.
+#' Either argument may be named, partially named, or positional;
+#' `match_expectation_args()` matches them as R does.
 #'
 #' Matching only message text is brittle:
 #' wording can change while the underlying condition type stays correct.
@@ -34,21 +36,8 @@ condition_class_linter <- function() {
     }
 
     needs_class <- vapply(calls, function(call) {
-      arg_names <- xml2::xml_text(xml2::xml_find_all(call, "./SYMBOL_SUB"))
-      has_class <- "class" %in% arg_names
-      has_named_regexp <- "regexp" %in% arg_names
-
-      # The second positional argument is the third direct `expr` child:
-      # function call, first argument, then unnamed `regexp`.
-      # Requiring an immediate preceding comma excludes named arguments,
-      # whose value expression is preceded by `EQ_SUB` instead.
-      positional_regexp <- xml2::xml_find_first(
-        call,
-        "./expr[3][preceding-sibling::*[1][self::OP-COMMA]]"
-      )
-      has_positional_regexp <- !inherits(positional_regexp, "xml_missing")
-
-      !has_class && (has_named_regexp || has_positional_regexp)
+      supplied <- match_expectation_args(call)
+      "regexp" %in% supplied && !("class" %in% supplied)
     }, logical(1))
 
     lintr::xml_nodes_to_lints(

lms/R/default_linters.R

@@ -0,0 +1,33 @@
+#' Default UCD-SERG lintr linters
+#'
+#' The canonical linter set for UCD-SERG repositories, matching the style
+#' guide in the lab manual. Applied repositories consume this from a thin
+#' `.lintr.R`:
+#'
+#' ```r
+#' linters <- lms::default_linters()
+#' exclusions <- list(...)   # repo-specific, stays local
+#' ```
+#'
+#' @return A list of linters, as produced by
+#'   [lintr::linters_with_defaults()].
+#' @export
+default_linters <- function() {
+  lintr::linters_with_defaults(
+    return_linter = NULL,
+    trailing_whitespace_linter = NULL,
+    lintr::redundant_equals_linter(),
+    lintr::pipe_consistency_linter(pipe = "|>"),
+    lintr::object_name_linter(
+      regexes = c(snake_case_ACROs1 = snake_case_acros_regex())
+    ),
+    lintr::undesirable_function_linter(
+      fun = undesirable_functions(),
+      symbol_is_undesirable = TRUE
+    ),
+    lintr::cyclocomp_linter(),
+    function_length_linter(),
+    function_location_linter(),
+    condition_class_linter()
+  )
+}

lms/R/function_length_linter.R

@@ -0,0 +1,45 @@
+#' Function-length linter
+#'
+#' Flags function definitions (including `\(...)` lambdas) that span more
+#' lines than `length_limit`, matching the provisional heuristic documented
+#' in "Function Length Limits" in *Principles of Scientific Computing*
+#' (<https://morrison-lab.github.io/psc/>)
+#' ("use `<150` lines... as a trigger to reassess decomposition, not a hard
+#' constraint"). lintr has no built-in linter for this
+#' (see <https://github.com/r-lib/lintr/issues/361>); `cyclocomp_linter()`
+#' covers the complementary branching-complexity heuristic.
+#'
+#' @param length_limit Maximum number of lines a function definition may
+#'   span before being flagged. Defaults to 150, matching the documented
+#'   heuristic.
+#' @return A [lintr::Linter()] object.
+#' @export
+function_length_linter <- function(length_limit = 150L) {
+  xpath <- "//FUNCTION/parent::expr | //OP-LAMBDA/parent::expr"
+
+  lintr::Linter(linter_level = "expression", function(source_expression) {
+    if (!lintr::is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+    fun_defs <- xml2::xml_find_all(xml, xpath)
+
+    n_lines <- as.integer(xml2::xml_attr(fun_defs, "line2")) -
+      as.integer(xml2::xml_attr(fun_defs, "line1")) + 1L
+
+    lintr::xml_nodes_to_lints(
+      fun_defs[n_lines > length_limit],
+      source_expression = source_expression,
+      lint_message = sprintf(
+        paste0(
+          "Function spans more than %d lines; consider decomposing it (see ",
+          "https://morrison-lab.github.io/psc/chapters/",
+          "coding-practices.html#sec-function-length-limits)."
+        ),
+        length_limit
+      ),
+      type = "warning"
+    )
+  })
+}

lms/R/match_expectation_args.R

@@ -0,0 +1,61 @@
+#' Which leading testthat expectation formals a call supplies
+#'
+#' Matches a call's arguments to the first three formals of
+#' `expect_error()`, `expect_warning()`, and `expect_message()`
+#' (`object`, `regexp`, `class`) the way R does:
+#' named arguments first, by exact or unique partial match,
+#' then unnamed arguments, in order, to the formals still unmatched.
+#' All three formals come before `...`, so partial matching applies to them.
+#'
+#' A call on the right of `|>` or a magrittr pipe (`%>%`, `%T>%`, `%<>%`)
+#' gets the piped value as its first unnamed argument,
+#' unless the call places it with a placeholder:
+#' `_` as a named argument for `|>`, or `.` as any argument for magrittr.
+#' An empty argument, as in `f(x, , y)` or `f(x, regexp = )`,
+#' takes its slot but supplies nothing.
+#' A forwarded `...` could supply any formal,
+#' so a call containing one is reported as supplying all three.
+#'
+#' @param call The call's `expr` node in lintr's XML parse tree.
+#' @return A character vector of the formals among
+#'   `object`, `regexp`, and `class` that the call supplies.
+#' @noRd
+match_expectation_args <- function(call) {
+  formals <- c("object", "regexp", "class")
+  slots <- call_arg_slots(call)
+
+  texts <- vapply(slots, function(slot) slot$text, character(1))
+  if ("..." %in% texts) {
+    return(formals)
+  }
+
+  arg_names <- vapply(slots, function(slot) slot$name, character(1))
+  is_named <- !is.na(arg_names)
+  unnamed_texts <- texts[!is_named]
+  matches <- pmatch(arg_names[is_named], formals)
+  hit <- !is.na(matches)
+  matched <- formals[matches[hit]]
+  # A named argument with an empty value (`regexp = `) takes its formal
+  # but supplies nothing.
+  named <- matched[nzchar(texts[is_named][hit])]
+
+  # A pipe passes its left side as the first unnamed argument,
+  # unless the call places it with a placeholder:
+  # `_` in a named argument for `|>`, or `.` in any argument for magrittr.
+  pipe <- piped_into(call)
+  placed <- if (identical(pipe, "|>")) {
+    "_" %in% texts[is_named]
+  } else {
+    "." %in% texts
+  }
+  if (!is.na(pipe) && !placed) {
+    unnamed_texts <- c("<piped value>", unnamed_texts)
+  }
+
+  unmatched <- setdiff(formals, matched)
+  n_filled <- min(length(unnamed_texts), length(unmatched))
+  filled <- unmatched[seq_len(n_filled)]
+  supplied <- nzchar(unnamed_texts[seq_len(n_filled)])
+
+  c(named, filled[supplied])
+}