From 931a88a246b758d8c78b8487c8f41e5f42e2f71c Mon Sep 17 00:00:00 2001 From: RasmusSkytte Date: Wed, 22 Jan 2025 15:07:39 +0000 Subject: [PATCH] chore: synced file(s) with ssi-dk/AEF-DDF --- .lintr | 18 +------- R/0_linters.R | 49 +++++++++++++++------ tests/testthat/helper-setup.R | 78 +++++++++++++++++++-------------- tests/testthat/test-0_linters.R | 4 +- 4 files changed, 86 insertions(+), 63 deletions(-) diff --git a/.lintr b/.lintr index c5d6f6d5..1e2fa28e 100644 --- a/.lintr +++ b/.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( diff --git a/R/0_linters.R b/R/0_linters.R index bfc99a78..96a22964 100644 --- a/R/0_linters.R +++ b/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) { diff --git a/tests/testthat/helper-setup.R b/tests/testthat/helper-setup.R index 9c9e8a74..f9531058 100644 --- a/tests/testthat/helper-setup.R +++ b/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)) } ) } diff --git a/tests/testthat/test-0_linters.R b/tests/testthat/test-0_linters.R index 4a8e3b2d..7a6b64b9 100644 --- a/tests/testthat/test-0_linters.R +++ b/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() )