chore: synced file(s) with ssi-dk/AEF-DDF

.lintr

@@ -1,21 +1,7 @@
-linters: c(
-    diseasy_code_linters(),
-    all_linters(
-      line_length_linter = NULL,          # We use 120, nolint-aware line length linter instead
-      cyclocomp_linter = NULL,            # Not required in diseasy style guide
-      keyword_quote_linter = NULL,        # Not required in diseasy style guide
-      implicit_integer_linter = NULL,     # Not required in diseasy style guide
-      extraction_operator_linter = NULL,  # Fails for .data$*
-      nonportable_path_linter = NULL,     # Any \\ is flagged. Therefore fails when escaping backslashes
-      undesirable_function_linter = NULL, # Library calls in vignettes are flagged and any call to options
-      unnecessary_lambda_linter = NULL,   # Fails for purrr::map with additional function arguments
-      strings_as_factors_linter = NULL,   # Seems to be some backwards compatibility stuff.
-      expect_identical_linter = NULL      # Seems a little aggressive to require this.
-    )
-  )
+linters: diseasy_code_linters()
 exclude_linter: paste0(
     "^ *: *(", # Any number of spaces before and after the colon
-    paste(c(names(lintr::all_linters()), names(diseasy_code_linters())), collapse = "|"), # Any of our linters
+    paste(names(diseasy_code_linters()), collapse = "|"), # Any of our linters
     ",| )+(\\.|$)" # As a comma separated list (with optional spaces) followed by a period or end of line
   )
 exclusions: c(

R/0_linters.R

@@ -8,12 +8,26 @@
 #' @return A list of linters
 #' @noRd
 diseasy_code_linters <- function() {
-  linters <- list(
-    "nolint_position_linter" = nolint_position_linter(120),
-    "nolint_line_length_linter" = nolint_line_length_linter(120),
-    "non_ascii_linter" = non_ascii_linter(),
-    "param_and_field_linter" = param_and_field_linter(),
-    "documentation_template_linter" = documentation_template_linter()
+  linters <- c(
+    list(
+      "nolint_position_linter" = nolint_position_linter(length = 120L),
+      "nolint_line_length_linter" = nolint_line_length_linter(length = 120L),
+      "non_ascii_linter" = non_ascii_linter(),
+      "param_and_field_linter" = param_and_field_linter(),
+      "documentation_template_linter" = documentation_template_linter()
+    ),
+    lintr::all_linters(
+      object_length_linter = lintr::object_length_linter(length = 40L), # We allow for longer variable names
+      line_length_linter = NULL,          # We use 120, nolint-aware line length linter instead
+      cyclocomp_linter = NULL,            # Not required in diseasy style guide
+      keyword_quote_linter = NULL,        # Not required in diseasy style guide
+      implicit_integer_linter = NULL,     # Not required in diseasy style guide
+      extraction_operator_linter = NULL,  # Fails for .data$*
+      nonportable_path_linter = NULL,     # Any \\ is flagged. Therefore fails when escaping backslashes
+      undesirable_function_linter = NULL, # Library calls in vignettes are flagged and any call to options
+      unnecessary_lambda_linter = NULL,   # Fails for purrr::map with additional function arguments
+      strings_as_factors_linter = NULL    # Seems to be some backwards compatibility stuff.
+    )
   )
 
   return(linters)
@@ -89,7 +103,9 @@ nolint_position_linter <- function(length = 80L) {
 #' nolint_line_length_linter: Ensure lines adhere to a given character limit, ignoring `nolint` statements
 #'
 #' @param length (`numeric`)\cr
-#'  Maximum line length allowed. Default is 80L (Hollerith limit)..
+#'  Maximum line length allowed.
+#' @param code_block_length (`numeric`)\cr
+#'  Maximum line length allowed for code blocks.
 #' @examples
 #' ## nolint_line_length_linter
 #' # will produce lints
@@ -106,8 +122,9 @@ nolint_position_linter <- function(length = 80L) {
 #'
 #' @importFrom rlang .data
 #' @noRd
-nolint_line_length_linter <- function(length = 80L) {
+nolint_line_length_linter <- function(length = 80L, code_block_length = 85L) {
   general_msg <- paste("Lines should not be more than", length, "characters.")
+  code_block_msg <- paste("Code blocks should not be more than", code_block_length, "characters.")
 
   lintr::Linter(
     function(source_expression) {
@@ -117,19 +134,23 @@ nolint_line_length_linter <- function(length = 80L) {
         return(list())
       }
 
-      nolint_regex <- r"{# ?no(lint|cov) ?(start|end)?:?.*}"
+      nolint_regex <- r"{\s*# ?no(lint|cov) ?(start|end)?:?.*}"
 
       file_lines_nolint_excluded <- source_expression$file_lines |>
         purrr::map_chr(\(s) stringr::str_remove(s, nolint_regex))
 
+      # Switch mode based on extension
+      # .Rmd uses code_block_length
+      code_block <- endsWith(tolower(source_expression$filename), ".rmd")
+
       line_lengths <- nchar(file_lines_nolint_excluded)
-      long_lines <- which(line_lengths > length)
+      long_lines <- which(line_lengths > ifelse(code_block, code_block_length, length))
       Map(function(long_line, line_length) {
         lintr::Lint(
           filename = source_expression$filename,
           line_number = long_line,
-          column_number = length + 1L, type = "style",
-          message = paste(general_msg, "This line is", line_length, "characters."),
+          column_number = ifelse(code_block, code_block_length, length) + 1L, type = "style",
+          message = paste(ifelse(code_block, code_block_msg, general_msg), "This line is", line_length, "characters."),
           line = source_expression$file_lines[long_line],
           ranges = list(c(1L, line_length))
         )
@@ -249,7 +270,7 @@ param_and_field_linter <- function() {
 
       # Remove auto-generated documentation
       detection_info <- detection_info |>
-        dplyr::filter(!stringr::str_detect(.data$rd_line, r"{@(param|field) +[\.\w]+ +`r }"))
+        dplyr::filter(!stringr::str_detect(.data$rd_line, r"{@(param|field) +[\.\,\w]+ +`r }"))
 
 
 
@@ -316,7 +337,7 @@ param_and_field_linter <- function() {
 #' @importFrom rlang .data
 #' @noRd
 documentation_template_linter <- function() {
-  general_msg <- paste("Documentation templates should used if available!")
+  general_msg <- paste("Documentation templates should used if available.")
 
   lintr::Linter(
     function(source_expression) {

tests/testthat/helper-setup.R

@@ -36,17 +36,17 @@ get_test_conns <- function(skip_backends = NULL) {
   } else {
 
     # Use the connection configured by the remote
-    conn_list <- tibble::lst(!!Sys.getenv("BACKEND") := !!Sys.getenv("BACKEND_DRV"))                                    # nolint: object_name_linter
+    conn_list <- tibble::lst(!!Sys.getenv("BACKEND") := !!Sys.getenv("BACKEND_DRV"))
 
     # Use the connection configured by the remote
-    conn_args <- tibble::lst(!!Sys.getenv("BACKEND") := Sys.getenv("BACKEND_ARGS")) |>                                  # nolint: object_name_linter
-      purrr::discard(~ identical(., "")) |>
-      purrr::map(~ eval(parse(text = .)))
+    conn_args <- tibble::lst(!!Sys.getenv("BACKEND") := Sys.getenv("BACKEND_ARGS"))
+    conn_args <- purrr::discard(conn_args, ~ identical(., ""))
+    conn_args <- purrr::map(conn_args, ~ eval(parse(text = .)))
 
     # Use the connection configured by the remote
-    conn_post_connect <- tibble::lst(!!Sys.getenv("BACKEND") := Sys.getenv("BACKEND_POST_CONNECT")) |>                  # nolint: object_name_linter
-      purrr::discard(~ identical(., "")) |>
-      purrr::map(~ eval(parse(text = .)))
+    conn_post_connect <- tibble::lst(!!Sys.getenv("BACKEND") := Sys.getenv("BACKEND_POST_CONNECT"))
+    conn_post_connect <- purrr::discard(conn_post_connect, ~ identical(., ""))
+    conn_post_connect <- purrr::map(conn_post_connect, ~ eval(parse(text = .)))
 
   }
 
@@ -60,9 +60,8 @@ get_test_conns <- function(skip_backends = NULL) {
 
   # Combine all arguments
   backends <- unique(c(names(conn_list), names(conn_args), names(conn_args_json)))
-  conn_args <- backends |>
-    purrr::map(~ c(purrr::pluck(conn_args, .), purrr::pluck(conn_args_json, .))) |>
-    stats::setNames(backends)
+  conn_args <- purrr::map(backends, ~ c(purrr::pluck(conn_args, .), purrr::pluck(conn_args_json, .)))
+  names(conn_args) <- backends
 
 
   get_driver <- function(x = character(), ...) {                                                                        # nolint: object_usage_linter
@@ -83,28 +82,43 @@ get_test_conns <- function(skip_backends = NULL) {
   checkmate::assert_subset(names(conn_args), names(conn_list))
 
   # Open connections
-  drivers <- names(conn_list) |>
-    purrr::map(~ do.call(get_driver, list(x = purrr::pluck(conn_list, .)))) |>
-    stats::setNames(names(conn_list)) |>
-    purrr::discard(is.null)
+  drivers <- purrr::map(names(conn_list), ~ do.call(get_driver, list(x = purrr::pluck(conn_list, .))))
+  names(drivers) <- names(conn_list)
+  drivers <- purrr::discard(drivers, is.null)
 
-  test_conns <- names(drivers) |>
-    purrr::map(~ do.call(SCDB::get_connection, c(list(drv = purrr::pluck(drivers, .)), purrr::pluck(conn_args, .)))) |>
-    stats::setNames(names(drivers)) |>
-    purrr::discard(is.null)
+  test_conn_args <- purrr::map(
+    names(drivers),
+    ~ c(list("drv" = purrr::pluck(drivers, .)), purrr::pluck(conn_args, .))
+  )
+
+  test_conns <- purrr::map(
+    test_conn_args,
+    ~ do.call(SCDB::get_connection, args = .)
+  )
+  names(test_conns) <- names(drivers)
+  test_conns <- purrr::discard(test_conns, is.null)
 
   # Skip backends if given
-  test_conns <- test_conns |>
-    purrr::walk(\(conn) {
-      if (checkmate::test_multi_class(conn, purrr::pluck(skip_backends, .default = ""))) {
-        DBI::dbDisconnect(conn)
+  test_conns <- purrr::walk(
+    test_conns,
+    ~ {
+      if (checkmate::test_multi_class(., purrr::pluck(skip_backends, .default = ""))) {
+        DBI::dbDisconnect(.)
       }
-    }) |>
-    purrr::discard(\(conn) checkmate::test_multi_class(conn, purrr::pluck(skip_backends, .default = "")))
+    }
+  )
+  test_conns <- purrr::discard(
+    test_conns,
+    ~ checkmate::test_multi_class(., purrr::pluck(skip_backends, .default = ""))
+  )
 
   # Run post_connect commands on the connections
-  purrr::walk2(test_conns, names(test_conns),
-               \(conn, conn_name) purrr::walk(purrr::pluck(conn_post_connect, conn_name), ~ DBI::dbExecute(conn, .)))
+  purrr::iwalk(
+    test_conns,
+    function(conn, conn_name) {
+      purrr::walk(purrr::pluck(conn_post_connect, conn_name), ~ DBI::dbExecute(conn, .))
+    }
+  )
 
   # Inform the user about the tested back ends:
   msg <- paste(sep = "\n",
@@ -141,12 +155,12 @@ get_test_conns <- function(skip_backends = NULL) {
 checkmate_err_msg <- function(expr) {
   tryCatch(
     expr,
-    error = \(e) {
-      e$message |>
-        stringr::str_remove_all(stringr::fixed("\n *")) |>
-        stringr::str_remove_all(stringr::fixed("* ")) |>
-        simpleError(message = _) |>
-        stop()
+    error = function(e) {
+      msg <- e$message
+      msg <- stringr::str_remove_all(msg, stringr::fixed("\n *"))
+      msg <- stringr::str_remove_all(msg, stringr::fixed("* "))
+
+      stop(simpleError(message = msg))
     }
   )
 }

tests/testthat/test-0_linters.R

@@ -61,9 +61,11 @@ test_that("param_and_field_linter works", {
 test_that("documentation_template_linter works", {
   skip_if_not_installed("lintr")
   skip_if_not_installed("devtools")
+  skip_if(!interactive(), "Skip if running in R_check")
+  skip_on_cran()
 
   lintr::expect_lint(
-    "#' @param observable (`character(1)`)\\cr", # rd_observable defined in R/0_documentation.R                         # nolint: documentation_template_linter
+    "#' @param observable text", # rd_observable defined in R/0_documentation.R                                         # nolint: documentation_template_linter, param_and_field_linter
     list("line_number" = 1, "type" = "style"),
     documentation_template_linter()
   )