diff --git a/.Rbuildignore b/.Rbuildignore index 1db1e0f1f..e609141bd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,6 +8,7 @@ ^\.Rproj\.user$ ^\.idea$ ^\.dev$ +^\.devcontainer$ ^\.lintr$ ^\.lintr_new$ ^wercker\.yml$ diff --git a/.dev/lint_metadata_test.R b/.dev/lint_metadata_test.R new file mode 100644 index 000000000..4b3c010b5 --- /dev/null +++ b/.dev/lint_metadata_test.R @@ -0,0 +1,54 @@ +# This script is designed to find linters that lack metadata tests. +# To do so, it forces Lint() to give the wrong information, +# runs the test suite, and finds linters that nevertheless pass all their tests. +library(testthat) + +lint_file <- "R/lint.R" + +original <- readLines(lint_file) +expected_line <- "line_number = as.integer(line_number)" +if (sum(grepl(expected_line, original, fixed = TRUE)) != 1L) { + stop(sprintf( + "Please update this workflow -- need exactly one hit for line '%s' in file '%s'.", + expected_line, lint_file + )) +} +writeLines( + sub(expected_line, "line_number = as.integer(2^31 - 1)", original, fixed = TRUE), + lint_file +) +# Not useful in CI but good when running locally. +withr::defer({ + writeLines(original, lint_file) + pkgload::load_all() +}) + +pkgload::load_all() + +report <- test_dir( + "tests/testthat", + filter = "linter$", + stop_on_failure = FALSE, + reporter = SilentReporter$new() +) +names(report) <- gsub("^test-|\\.R$", "", vapply(report, `[[`, "file", FUN.VALUE = character(1L))) + +# Hack the nested structure of the testthat report to identify which files have +# any failed test +failed <- report |> + vapply( + \(x) any(vapply(x$results, inherits, "expectation_failure", FUN.VALUE = logical(1L))), + logical(1L) + ) |> + which() |> + names() |> + unique() + +passed <- setdiff( + available_linters(tags = NULL)$linter, + failed +) + +if (length(passed) > 0L) { + stop("Please add tests of lint metadata for the following linters: ", toString(passed)) +} diff --git a/.dev/roxygen_test.R b/.dev/roxygen_test.R new file mode 100644 index 000000000..c595dbafd --- /dev/null +++ b/.dev/roxygen_test.R @@ -0,0 +1,54 @@ +# Test to ensure roxygenize() has been run on the current PR +library(tools) +library(roxygen2) + +old_dir <- file.path(tempdir(), "man") +if (dir.exists(old_dir)) unlink(old_dir, recursive = TRUE) +file.copy("man", tempdir(), recursive = TRUE) +old_files <- list.files(old_dir, pattern = "\\.Rd$") +new_dir <- "man" +.Last <- function() unlink(old_dir, recursive = TRUE) + +# Rd2txt() prints to its out= argument, so we'd have to compare file contents; +# plain parse_Rd() keeps srcref info that encodes the file path, which as.character() strips. +normalize_rd <- function(rd_file) as.character(parse_Rd(rd_file)) + +rd_equal <- function(f1, f2) isTRUE(all.equal(normalize_rd(f1), normalize_rd(f2))) + +check_roxygenize_idempotent <- function(LOCALE) { + Sys.setlocale("LC_COLLATE", LOCALE) + roxygenize() + + new_files <- list.files(new_dir, pattern = "\\.Rd$") + + old_not_new <- setdiff(old_files, new_files) + if (length(old_not_new) > 0L) { + stop("Found saved .Rd files gone from a fresh run of roxygenize(): ", toString(old_not_new)) + } + + new_not_old <- setdiff(new_files, old_files) + if (length(new_not_old) > 0L) { + stop("Found new .Rd files from a fresh run of roxygenize(): ", toString(new_not_old)) + } + + for (file in new_files) { + old_file <- file.path(old_dir, file) + new_file <- file.path(new_dir, file) + if (rd_equal(old_file, new_file)) { + next + } + cat(sprintf("roxygenize() output differs from saved output for %s.\n", file)) + cat("Here's the 'diff' comparison of the two files:\n") + cat(" [---]: saved output in man/ directory\n") + cat(" [+++]: roxygenize() output of R/ sources\n") + system2("diff", c("--unified", old_file, new_file)) + stop("Failed in LOCALE=", LOCALE, ".", call. = FALSE) + } +} + +# Run the check in a few locales to ensure there's no idempotency issues w.r.t. sorting, too +for (LOCALE in c("C", "en_US", "hu_HU", "ja_JP")) { + check_roxygenize_idempotent(LOCALE) +} + +unlink(old_dir, recursive = TRUE) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile new file mode 100644 index 000000000..768428f4c --- /dev/null +++ b/.devcontainer/Dockerfile @@ -0,0 +1,14 @@ +FROM rocker/r-base + +RUN apt-get -qq update && \ + apt-get install -y --no-install-recommends git libxml2-dev + +COPY DESCRIPTION . + +RUN Rscript -e ' \ + install.packages("remotes"); \ + remotes::install_deps(dependencies = c( \ + "Imports", \ + "Config/needs/development" \ + )) \ +' diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json new file mode 100644 index 000000000..b30eaba32 --- /dev/null +++ b/.devcontainer/devcontainer.json @@ -0,0 +1,3 @@ +{ + "build": { "dockerfile": "Dockerfile", "context": ".."} +} diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 72bc4f4de..c57070bef 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -37,7 +37,7 @@ jobs: # Use older ubuntu to maximise backward compatibility - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release', locale: 'en_US'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release', locale: 'zh_CN'} + - {os: ubuntu-latest, r: 'release', http-user-agent: 'release', locale: 'zh_CN'} - {os: ubuntu-latest, r: 'release'} - {os: ubuntu-latest, r: 'oldrel-1'} - {os: ubuntu-latest, r: 'oldrel-2'} diff --git a/.github/workflows/check-link-rot.yaml b/.github/workflows/check-link-rot.yaml deleted file mode 100644 index e83026690..000000000 --- a/.github/workflows/check-link-rot.yaml +++ /dev/null @@ -1,41 +0,0 @@ -on: - push: - branches: [main, master] - pull_request: - branches: [main, master] - -name: check-link-rot - -jobs: - check-link-rot: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - steps: - - uses: actions/checkout@v4 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: "devel" - http-user-agent: "release" - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - pak-version: devel - extra-packages: | - any::rcmdcheck - any::urlchecker - - - name: Run URL checker - run: | - options(crayon.enabled = TRUE) - rotten_links <- urlchecker::url_check(progress = FALSE) - print(rotten_links) - if (length(rotten_links$URL) > 0L) { - stop("Some URLs are outdated and need to be updated.", call. = FALSE) - } - shell: Rscript {0} diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 48e1d1dc7..921325d8e 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -39,7 +39,7 @@ jobs: - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' - uses: JamesIves/github-pages-deploy-action@v4.4.3 + uses: JamesIves/github-pages-deploy-action@v4.5.0 with: clean: false branch: gh-pages diff --git a/.github/workflows/repo-meta-tests.yaml b/.github/workflows/repo-meta-tests.yaml new file mode 100644 index 000000000..624f54d63 --- /dev/null +++ b/.github/workflows/repo-meta-tests.yaml @@ -0,0 +1,38 @@ +# Various repo-level tests for code quality +on: + push: + branches: [main] + pull_request: + branches: [main] + +name: repo-meta-tests + +jobs: + repo-meta-tests: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: "release" + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: | + any::roxygen2 + + - name: Ensure lint metadata is tested + run: | + options(crayon.enabled = TRUE) + callr::rscript(".dev/lint_metadata_test.R") + shell: Rscript {0} + + - name: Ensure roxygen content matches man directory + run: | + callr::rscript(".dev/roxygen_test.R") + shell: Rscript {0} diff --git a/.lintr b/.lintr index ef0b7d813..e9b2a3cb0 100644 --- a/.lintr +++ b/.lintr @@ -2,6 +2,15 @@ linters: all_linters( backport_linter("3.6.0", except = c("R_user_dir", "deparse1", "...names")), line_length_linter(120L), object_overwrite_linter(allow_names = c("line", "lines", "pipe", "symbols")), + todo_comment_linter( + except_regex = rex::rex( + "TODO(", + # GitHub issue number #1234, possibly from another repo org/repo#5678 + maybe(one_or_more(character_class("a-zA-Z0-9-")), "/", one_or_more(character_class("a-zA-Z0-9._-"))), + "#", one_or_more(digit), + ")" + ) + ), undesirable_function_linter(modify_defaults( defaults = default_undesirable_functions, library = NULL, @@ -14,7 +23,6 @@ linters: all_linters( )), unnecessary_concatenation_linter(allow_single_expression = FALSE), absolute_path_linter = NULL, - extraction_operator_linter = NULL, library_call_linter = NULL, nonportable_path_linter = NULL, todo_comment_linter = NULL, diff --git a/DESCRIPTION b/DESCRIPTION index 9fc54ec13..d31c1dae8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,14 +37,12 @@ Imports: Suggests: bookdown, cli, - httr (>= 1.2.1), jsonlite, - mockery, - patrick, + patrick (>= 0.2.0), rlang, rmarkdown, rstudioapi (>= 0.2), - testthat (>= 3.1.5), + testthat (>= 3.2.1), tibble, tufte, withr (>= 2.5.0) @@ -53,11 +51,12 @@ Enhances: VignetteBuilder: knitr Config/Needs/website: tidyverse/tidytemplate +Config/Needs/development: pkgload, cli, testthat, patrick Config/testthat/edition: 3 Config/testthat/parallel: true Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Collate: 'make_linter_from_xpath.R' 'xp_utils.R' @@ -76,8 +75,7 @@ Collate: 'cache.R' 'class_equals_linter.R' 'commas_linter.R' - 'comment_linters.R' - 'comments.R' + 'commented_code_linter.R' 'comparison_negation_linter.R' 'condition_call_linter.R' 'condition_message_linter.R' @@ -103,7 +101,6 @@ Collate: 'expect_true_false_linter.R' 'expect_type_linter.R' 'extract.R' - 'extraction_operator_linter.R' 'fixed_regex_linter.R' 'for_loop_index_linter.R' 'function_argument_linter.R' @@ -144,6 +141,7 @@ Collate: 'nested_ifelse_linter.R' 'nested_pipe_linter.R' 'nonportable_path_linter.R' + 'shared_constants.R' 'nrow_subset_linter.R' 'numeric_leading_zero_linter.R' 'nzchar_linter.R' @@ -176,8 +174,8 @@ Collate: 'seq_linter.R' 'settings.R' 'settings_utils.R' - 'shared_constants.R' 'sort_linter.R' + 'source_utils.R' 'spaces_inside_linter.R' 'spaces_left_parentheses_linter.R' 'sprintf_linter.R' @@ -186,6 +184,7 @@ Collate: 'strings_as_factors_linter.R' 'system_file_linter.R' 'terminal_close_linter.R' + 'todo_comment_linter.R' 'trailing_blank_lines_linter.R' 'trailing_whitespace_linter.R' 'tree_utils.R' @@ -193,7 +192,6 @@ Collate: 'undesirable_operator_linter.R' 'unnecessary_concatenation_linter.R' 'unnecessary_lambda_linter.R' - 'unnecessary_nested_if_linter.R' 'unnecessary_nesting_linter.R' 'unnecessary_placeholder_linter.R' 'unreachable_code_linter.R' diff --git a/NAMESPACE b/NAMESPACE index 7f02530be..00d9ad2e0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -95,6 +95,7 @@ export(linters_with_defaults) export(linters_with_tags) export(list_comparison_linter) export(literal_coercion_linter) +export(make_linter_from_function_xpath) export(make_linter_from_xpath) export(matrix_apply_linter) export(missing_argument_linter) @@ -190,6 +191,7 @@ importFrom(utils,tail) importFrom(utils,txtProgressBar) importFrom(xml2,as_list) importFrom(xml2,xml_attr) +importFrom(xml2,xml_children) importFrom(xml2,xml_find_all) importFrom(xml2,xml_find_chr) importFrom(xml2,xml_find_first) diff --git a/NEWS.md b/NEWS.md index 74c7be3ce..87cfd9ff2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,15 +11,20 @@ + Linters `closed_curly_linter()`, `open_curly_linter()`, `paren_brace_linter()`, and `semicolon_terminator_linter()`. + Helper `with_defaults()`. * `all_linters()` has signature `all_linters(..., packages)` rather than `all_linters(packages, ...)` (#2332, @MichaelChirico). This forces `packages=` to be supplied by name and will break users who rely on supplying `packages=` positionally, of which we found none searching GitHub. +* Adjusted various lint messages for consistency in readability (#1330, @MichaelChirico). In general, we favor lint messages to be phrased like "Action, reason" to but the "what" piece of the message front-and-center. This may be a breaking change for code that tests the specific phrasing of lints. +* `extraction_operator_linter()` is deprecated. Although switching from `$` to `[[` has some robustness benefits for package code, it can lead to non-idiomatic code in many contexts (e.g. R6 classes, Shiny applications, etc.) (#2409, @IndrajeetPatil). To enable the detection of the `$` operator for extraction through partial matching, use `options(warnPartialMatchDollar = TRUE)`. +* `unnecessary_nested_if_linter()` is deprecated and subsumed into the new/more general `unnecessary_nesting_linter()`. +* Drop support for posting GitHub comments from inside Travis, Wercker, and Jenkins CI tools (spurred by #2148, @MichaelChirico). We rely on GitHub Actions for linting in CI, and don't see any active users relying on these alternatives. We welcome and encourage community contributions to get support for different CI system going again. ## Bug fixes * `object_name_linter()` no longer errors when user-supplied `regexes=` have capture groups (#2188, @MichaelChirico). -* `.lintr` config validation correctly accepts regular exressions which only compile under `perl = TRUE` (#2375, @MichaelChirico). These have always been valid (since `rex::re_matches()`, which powers the lint exclusion logic, also uses this setting), but the new up-front validation in v3.1.1 incorrectly used `perl = FALSE`. +* `.lintr` config validation correctly accepts regular expressions which only compile under `perl = TRUE` (#2375, @MichaelChirico). These have always been valid (since `rex::re_matches()`, which powers the lint exclusion logic, also uses this setting), but the new up-front validation in v3.1.1 incorrectly used `perl = FALSE`. +* `.lintr` configs set by option `lintr.linter_file` or environment variable `R_LINTR_LINTER_FILE` can point to subdirectories (#2512, @MichaelChirico). ## Changes to default linters -* New default linter `return_linter()` for the style guide rule that terminal returns should be left implicit (#1100, @MEO265). +* New default linter `return_linter()` for the style guide rule that terminal returns should be left implicit (#1100, #2343, #2354, and #2356, @MEO265 and @MichaelChirico). ## New and improved features @@ -27,11 +32,23 @@ * `library_call_linter()` is extended + to encourage all packages to be attached with `library(symbol)`, not `library("symbol", character.only = TRUE)` or "vectorized" approaches looping over package names (part of #884, @MichaelChirico). + to discourage many consecutive calls to `suppressMessages()` or `suppressPackageStartupMessages()` (part of #884, @MichaelChirico). -* `return_linter()` also has an argument `return_style` (`"implicit"` by default) which checks that all functions confirm to the specified return style of `"implicit"` or `"explicit"` (part of #884, @MichaelChirico, @AshesITR and @MEO265). +* `return_linter()` also has arguments for fine-tuning which functions get linted: + + `return_style` (`"implicit"` by default) which checks that all functions confirm to the specified return style of `"implicit"` or `"explicit"` (#2271 and part of #884, @MichaelChirico, @AshesITR and @MEO265). + + `allow_implicit_else` (default `TRUE`) which, when `FALSE`, checks that all terminal `if` statements are paired with a corresponding `else` statement (part of #884, @MichaelChirico). + + `return_functions` to customize which functions are equivalent to `return()` as "exit" clauses, e.g. `rlang::abort()` can be considered in addition to the default functions like `stop()` and `q()` from base (#2271 and part of #884, @MichaelChirico and @MEO265). + + `except` to customize which functions are ignored entirely (i.e., whether they have a return of the specified style is not checked; #2271 and part of #884, @MichaelChirico and @MEO265). Namespace hooks like `.onAttach()` and `.onLoad()` are always ignored. + + `except_regex`, the same purpose as `except=`, but filters functions by pattern. This is motivated by {RUnit}, where test suites are based on unit test functions matched by pattern, e.g. `^Test`, and where explicit return may be awkward (#2335, @MichaelChirico). * `unnecessary_lambda_linter` is extended to encourage vectorized comparisons where possible, e.g. `sapply(x, sum) > 0` instead of `sapply(x, function(x) sum(x) > 0)` (part of #884, @MichaelChirico). Toggle this behavior with argument `allow_comparison`. * `backport_linter()` is slightly faster by moving expensive computations outside the linting function (#2339, #2348, @AshesITR and @MichaelChirico). * `Linter()` has a new argument `linter_level` (default `NA`). This is used by `lint()` to more efficiently check for expression levels than the idiom `if (!is_lint_level(...)) { return(list()) }` (#2351, @AshesITR). +* `string_boundary_linter()` recognizes regular expression calls like `grepl("^abc$", x)` that can be replaced by using `==` instead (#1613, @MichaelChirico). +* `unreachable_code_linter()` has an argument `allow_comment_regex` for customizing which "terminal" comments to exclude (#2327, @MichaelChirico). `# nolint end` comments are always excluded, as are {covr} exclusions (e.g. `# nocov end`) by default. * `format()` and `print()` methods for `lint` and `lints` classes get a new option `width` to control the printing width of lint messages (#1884, @MichaelChirico). The default is controlled by a new option `lintr.format_width`; if unset, no wrapping occurs (matching earlier behavior). +* `implicit_assignment_linter()` gets a custom message for the case of using `(` to induce printing like `(x <- foo())`; use an explicit call to `print()` for clarity (#2257, @MichaelChirico). +* New function node caching for big efficiency gains to most linters (e.g. overall `lint_package()` improvement of 14-27% and core linting improvement up to 30%; #2357, @AshesITR). Most linters are written around function usage, and XPath performance searching for many functions is poor. The new `xml_find_function_calls()` entry in the `get_source_expressions()` output caches all function call nodes instead. See the vignette on creating linters for more details on how to use it. +* `todo_comment_linter()` has a new argument `except_regex` for setting _valid_ TODO comments, e.g. for forcing TODO comments to be linked to GitHub issues like `TODO(#154)` (#2047, @MichaelChirico). +* `vector_logic_linter()` is extended to recognize incorrect usage of scalar operators `&&` and `||` inside subsetting expressions like `dplyr::filter(x, A && B)` (#2166, @MichaelChirico). +* `any_is_na_linter()` is extended to catch the unusual usage `NA %in% x` (#2113, @MichaelChirico). ### New linters @@ -45,11 +62,11 @@ * `which_grepl_linter()` for discouraging `which(grepl(ptn, x))` in favor of directly using `grep(ptn, x)` (part of #884, @MichaelChirico). * `list_comparison_linter()` for discouraging comparisons on the output of `lapply()`, e.g. `lapply(x, sum) > 10` (part of #884, @MichaelChirico). * `print_linter()` for discouraging usage of `print()` on string literals like `print("Reached here")` or `print(paste("Found", nrow(DF), "rows."))` (#1894, @MichaelChirico). -* `unnecessary_nesting_linter()` for discouraging overly-nested code where an early return or eliminated sub-expression (inside '{') is preferable (part of #884, @MichaelChirico). +* `unnecessary_nesting_linter()` for discouraging overly-nested code where an early return or eliminated sub-expression (inside '{') is preferable (#2317, #2334 and part of #884, @MichaelChirico). * `consecutive_mutate_linter()` for encouraging consecutive calls to `dplyr::mutate()` to be combined (part of #884, @MichaelChirico). -* `if_switch_linter()` for encouraging `switch()` over repeated `if`/`else` tests (part of #884, @MichaelChirico). +* `if_switch_linter()` for encouraging `switch()` over repeated `if`/`else` tests (#2322 and part of #884, @MichaelChirico). * `nested_pipe_linter()` for discouraging pipes within pipes, e.g. `df1 %>% inner_join(df2 %>% select(a, b))` (part of #884, @MichaelChirico). -* `nrow_subset_linter()` for discouraging usage like `nrow(subset(x, conditions))` in favor of something like `with(x, sum(conditions))` which doesn't require a full subset of `x` (part of #884, @MichaelChirico). +* `nrow_subset_linter()` for discouraging usage like `nrow(subset(x, conditions))` in favor of something like `with(x, sum(conditions))` which doesn't require a full subset of `x` (#2313, #2314 and part of #884, @MichaelChirico). * `pipe_return_linter()` for discouraging usage of `return()` inside a {magrittr} pipeline (part of #884, @MichaelChirico). * `one_call_pipe_linter()` for discouraging one-step pipelines like `x |> as.character()` (#2330 and part of #884, @MichaelChirico). * `object_overwrite_linter()` for discouraging re-use of upstream package exports as local variables (#2344, #2346 and part of #884, @MichaelChirico and @AshesITR). @@ -60,6 +77,14 @@ * `unnecessary_lambda_linter()` + ignores extractions with explicit returns like `lapply(l, function(x) foo(x)$bar)` (#2258, @MichaelChirico). + ignores calls on the RHS of operators like `lapply(l, function(x) "a" %in% names(x))` (#2310, @MichaelChirico). +* `vector_logic_linter()` recognizes some cases where bitwise `&`/`|` are used correctly (#1453, @MichaelChirico). +* `expect_comparison_linter()` ignores faulty usage like `expect_true(x, y > z)` (#2083, @MichaelChirico). Note that `y > z` is being passed to the `info=` argument, so this is likely a mistake. +* `consecutive_assertion_linter()` ignores cases where a second asssertion follows assignment with `=` (#2444, @MichaelChirico). + +### Lint accuracy fixes: removing false negatives + +* `missing_argument_linter()` catches all missing arguments in calls with several, e.g. `foo(,,)` gives 3 lints instead of 2 (#2399, @MichaelChirico). +* `duplicate_argument_linter()` no longer misses cases with duplicate arguments where a comment comes between the argument name and `=` (#2402, @MichaelChirico). # lintr 3.1.1 diff --git a/R/T_and_F_symbol_linter.R b/R/T_and_F_symbol_linter.R index 6a4f03117..b6c1300c7 100644 --- a/R/T_and_F_symbol_linter.R +++ b/R/T_and_F_symbol_linter.R @@ -1,6 +1,7 @@ #' `T` and `F` symbol linter #' -#' Avoid the symbols `T` and `F`, and use `TRUE` and `FALSE` instead. +#' Although they can be synonyms, avoid the symbols `T` and `F`, and use `TRUE` and `FALSE`, respectively, instead. +#' `T` and `F` are not reserved keywords and can be assigned to any other values. #' #' @examples #' # will produce lints @@ -45,7 +46,7 @@ T_and_F_symbol_linter <- function() { # nolint: object_name. Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + bad_usage <- xml_find_all(xml, usage_xpath) bad_assignment <- xml_find_all(xml, assignment_xpath) diff --git a/R/any_duplicated_linter.R b/R/any_duplicated_linter.R index cb20da3f8..04a80bd84 100644 --- a/R/any_duplicated_linter.R +++ b/R/any_duplicated_linter.R @@ -35,8 +35,7 @@ #' @export any_duplicated_linter <- function() { any_duplicated_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'any'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'duplicated']]] /parent::expr[ count(expr) = 2 @@ -87,9 +86,9 @@ any_duplicated_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + xml_calls <- source_expression$xml_find_function_calls("any") - any_duplicated_expr <- xml_find_all(xml, any_duplicated_xpath) + any_duplicated_expr <- xml_find_all(xml_calls, any_duplicated_xpath) any_duplicated_lints <- xml_nodes_to_lints( any_duplicated_expr, source_expression = source_expression, diff --git a/R/any_is_na_linter.R b/R/any_is_na_linter.R index ed0ce8639..5aa1a0cad 100644 --- a/R/any_is_na_linter.R +++ b/R/any_is_na_linter.R @@ -36,9 +36,8 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export any_is_na_linter <- function() { - xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'any'] - /parent::expr + any_xpath <- " + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.na']]] /parent::expr[ count(expr) = 2 @@ -46,17 +45,28 @@ any_is_na_linter <- function() { ] " + in_xpath <- "//SPECIAL[text() = '%in%']/preceding-sibling::expr[NUM_CONST[starts-with(text(), 'NA')]]" + Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("any") - xml_nodes_to_lints( - bad_expr, + any_expr <- xml_find_all(xml_calls, any_xpath) + any_lints <- xml_nodes_to_lints( + any_expr, source_expression = source_expression, lint_message = "anyNA(x) is better than any(is.na(x)).", type = "warning" ) + + in_expr <- xml_find_all(xml, in_xpath) + in_lints <- xml_nodes_to_lints( + in_expr, + source_expression = source_expression, + lint_message = "anyNA(x) is better than NA %in% x.", + type = "warning" + ) + + c(any_lints, in_lints) }) } diff --git a/R/assignment_linter.R b/R/assignment_linter.R index 6bbe83d41..da42b5119 100644 --- a/R/assignment_linter.R +++ b/R/assignment_linter.R @@ -101,7 +101,6 @@ assignment_linter <- function(allow_cascading_assign = TRUE, Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) if (length(bad_expr) == 0L) { @@ -111,7 +110,7 @@ assignment_linter <- function(allow_cascading_assign = TRUE, operator <- xml_text(bad_expr) lint_message_fmt <- rep("Use <-, not %s, for assignment.", length(operator)) lint_message_fmt[operator %in% c("<<-", "->>")] <- - "%s can have hard-to-predict behavior; prefer assigning to a specific environment instead (with assign() or <-)." + "Replace %s by assigning to a specific environment (with assign() or <-) to avoid hard-to-predict behavior." lint_message_fmt[operator == "%<>%"] <- "Avoid the assignment pipe %s; prefer using <- and %%>%% separately." diff --git a/R/backport_linter.R b/R/backport_linter.R index 22230bd1b..3c1eaeaeb 100644 --- a/R/backport_linter.R +++ b/R/backport_linter.R @@ -45,29 +45,28 @@ backport_linter <- function(r_version = getRversion(), except = character()) { backport_index <- rep(names(backport_blacklist), times = lengths(backport_blacklist)) names(backport_index) <- unlist(backport_blacklist) - names_xpath <- "//SYMBOL | //SYMBOL_FUNCTION_CALL" - Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - all_names_nodes <- xml_find_all(xml, names_xpath) + used_symbols <- xml_find_all(xml, "//SYMBOL") + used_symbols <- used_symbols[xml_text(used_symbols) %in% names(backport_index)] + + all_names_nodes <- combine_nodesets( + source_expression$xml_find_function_calls(names(backport_index)), + used_symbols + ) all_names <- xml_text(all_names_nodes) bad_versions <- unname(backport_index[all_names]) - needs_backport <- !is.na(bad_versions) lint_message <- sprintf( - paste( - "%s (R %s) is not available for dependency R >= %s.", - "Use the `except` argument of `backport_linter()` to configure available backports." - ), - all_names[needs_backport], - bad_versions[needs_backport], + "%s (R %s) is not available for dependency R >= %s.", + all_names, + bad_versions, r_version ) xml_nodes_to_lints( - all_names_nodes[needs_backport], + all_names_nodes, source_expression = source_expression, lint_message = lint_message, type = "warning" @@ -122,7 +121,8 @@ normalize_r_version <- function(r_version) { # devel NEWS https://cran.rstudio.com/doc/manuals/r-devel/NEWS.html # release NEWS https://cran.r-project.org/doc/manuals/r-release/NEWS.html backports <- list( - `4.3.0` = character(), # R devel needs to be ahead of all other versions + `4.3.0` = c("R_compiled_by", "array2DF"), + `4.2.1` = "findCRANmirror", `4.2.0` = c(".pretty", ".LC.categories", "Sys.setLanguage()"), `4.1.3` = character(), # need these for oldrel specifications `4.1.0` = c("numToBits", "numToInts", "gregexec", "charClass", "checkRdContents", "...names"), diff --git a/R/boolean_arithmetic_linter.R b/R/boolean_arithmetic_linter.R index 0dee92137..7ac2efa7b 100644 --- a/R/boolean_arithmetic_linter.R +++ b/R/boolean_arithmetic_linter.R @@ -35,8 +35,7 @@ boolean_arithmetic_linter <- function() { zero_expr <- "(EQ or NE or GT or LE) and expr[NUM_CONST[text() = '0' or text() = '0L']]" one_expr <- "(LT or GE) and expr[NUM_CONST[text() = '1' or text() = '1L']]" length_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'which' or text() = 'grep'] - /parent::expr + parent::expr /parent::expr /parent::expr[ expr[SYMBOL_FUNCTION_CALL[text() = 'length']] @@ -44,8 +43,7 @@ boolean_arithmetic_linter <- function() { ] ") sum_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'sum'] - /parent::expr + parent::expr /parent::expr[ expr[ expr[SYMBOL_FUNCTION_CALL[text() = 'grepl']] @@ -53,18 +51,19 @@ boolean_arithmetic_linter <- function() { ] and parent::expr[ ({zero_expr}) or ({one_expr})] ] ") - any_xpath <- paste(length_xpath, "|", sum_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - any_expr <- xml_find_all(xml, any_xpath) + length_calls <- source_expression$xml_find_function_calls(c("which", "grep")) + sum_calls <- source_expression$xml_find_function_calls("sum") + any_expr <- c( + xml_find_all(length_calls, length_xpath), + xml_find_all(sum_calls, sum_xpath) + ) xml_nodes_to_lints( any_expr, source_expression = source_expression, - # TODO(michaelchirico): customize this? + # TODO(#2464): customize this? lint_message = paste( "Use any() to express logical aggregations.", "For example, replace length(which(x == y)) == 0 with !any(x == y)." diff --git a/R/brace_linter.R b/R/brace_linter.R index 1c0337a24..7eda5a714 100644 --- a/R/brace_linter.R +++ b/R/brace_linter.R @@ -74,7 +74,7 @@ brace_linter <- function(allow_single_line = FALSE) { )") )) - # TODO (AshesITR): if c_style_braces is TRUE, invert the preceding-sibling condition + # TODO(#1103): if c_style_braces is TRUE, invert the preceding-sibling condition xp_open_curly <- glue("//OP-LEFT-BRACE[ { xp_cond_open } and ( @@ -109,7 +109,7 @@ brace_linter <- function(allow_single_line = FALSE) { )" )) - # TODO (AshesITR): if c_style_braces is TRUE, skip the not(ELSE) condition + # TODO(#1103): if c_style_braces is TRUE, skip the not(ELSE) condition xp_closed_curly <- glue("//OP-RIGHT-BRACE[ { xp_cond_closed } and ( @@ -121,7 +121,7 @@ brace_linter <- function(allow_single_line = FALSE) { xp_else_closed_curly <- "preceding-sibling::IF/following-sibling::expr[2]/OP-RIGHT-BRACE" # need to (?) repeat previous_curly_path since != will return true if there is # no such node. ditto for approach with not(@line1 = ...). - # TODO (AshesITR): if c_style_braces is TRUE, this needs to be @line2 + 1 + # TODO(#1103): if c_style_braces is TRUE, this needs to be @line2 + 1 xp_else_same_line <- glue("//ELSE[{xp_else_closed_curly} and @line1 != {xp_else_closed_curly}/@line2]") xp_function_brace <- "(//FUNCTION | //OP-LAMBDA)/parent::expr[@line1 != @line2 and not(expr[OP-LEFT-BRACE])]" @@ -148,7 +148,7 @@ brace_linter <- function(allow_single_line = FALSE) { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + lints <- list() lints <- c( @@ -194,7 +194,7 @@ brace_linter <- function(allow_single_line = FALSE) { xml_nodes_to_lints( xml_find_all(xml, xp_function_brace), source_expression = source_expression, - lint_message = "Any function spanning multiple lines should use curly braces." + lint_message = "Use curly braces for any function spanning multiple lines." ) ) diff --git a/R/class_equals_linter.R b/R/class_equals_linter.R index 5ee712cf1..2dd24b83d 100644 --- a/R/class_equals_linter.R +++ b/R/class_equals_linter.R @@ -35,8 +35,7 @@ #' @export class_equals_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'class'] - /parent::expr + parent::expr /parent::expr /parent::expr[ not(preceding-sibling::OP-LEFT-BRACKET) @@ -45,14 +44,12 @@ class_equals_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("class") + bad_expr <- xml_find_all(xml_calls, xpath) operator <- xml_find_chr(bad_expr, "string(*[2])") lint_message <- sprintf( - "Instead of comparing class(x) with %s, use inherits(x, 'class-name') or is. or is(x, 'class')", + "Use inherits(x, 'class-name'), is. or is(x, 'class') instead of comparing class(x) with %s.", operator ) xml_nodes_to_lints( diff --git a/R/commas_linter.R b/R/commas_linter.R index e7b9feda7..aeaf42878 100644 --- a/R/commas_linter.R +++ b/R/commas_linter.R @@ -79,12 +79,11 @@ commas_linter <- function(allow_trailing = FALSE) { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) before_lints <- xml_nodes_to_lints( xml_find_all(xml, xpath_before), source_expression = source_expression, - lint_message = "Commas should never have a space before.", + lint_message = "Remove spaces before a comma.", range_start_xpath = "number(./preceding-sibling::*[1]/@col2 + 1)", # start after preceding expression range_end_xpath = "number(./@col1 - 1)" # end before comma ) @@ -92,7 +91,7 @@ commas_linter <- function(allow_trailing = FALSE) { after_lints <- xml_nodes_to_lints( xml_find_all(xml, xpath_after), source_expression = source_expression, - lint_message = "Commas should always have a space after.", + lint_message = "Put a space after a comma.", range_start_xpath = "number(./@col2 + 1)", # start and end after comma range_end_xpath = "number(./@col2 + 1)" ) diff --git a/R/comment_linters.R b/R/commented_code_linter.R similarity index 54% rename from R/comment_linters.R rename to R/commented_code_linter.R index 26c107ffc..fcc4af9ef 100644 --- a/R/comment_linters.R +++ b/R/commented_code_linter.R @@ -1,29 +1,3 @@ -ops <- list( - "+", - # "-", - "=", - "==", - "!=", - "<=", - ">=", - "<-", - "<<-", - "<", - ">", - "->", - "->>", - "%%", - "/", - "^", - "*", - "**", - "|", - "||", - "&", - "&&", - rex("%", except_any_of("%"), "%") -) - #' Commented code linter #' #' Check that there is no commented code outside roxygen blocks. @@ -60,6 +34,32 @@ ops <- list( #' @seealso [linters] for a complete list of linters available in lintr. #' @export commented_code_linter <- function() { + ops <- list( + "+", + # "-", + "=", + "==", + "!=", + "<=", + ">=", + "<-", + "<<-", + "<", + ">", + "->", + "->>", + "%%", + "/", + "^", + "*", + "**", + "|", + "||", + "&", + "&&", + rex("%", except_any_of("%"), "%") + ) + code_candidate_regex <- rex( some_of("#"), any_spaces, @@ -78,7 +78,7 @@ commented_code_linter <- function() { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) + all_comment_nodes <- xml_find_all(xml, "//COMMENT") all_comments <- xml_text(all_comment_nodes) code_candidates <- re_matches(all_comments, code_candidate_regex, global = FALSE, locations = TRUE) @@ -91,7 +91,7 @@ commented_code_linter <- function() { lint_list <- xml_nodes_to_lints( all_comment_nodes[is_parsable], source_expression = source_expression, - lint_message = "Commented code should be removed." + lint_message = "Remove commented code." ) # Location info needs updating @@ -117,69 +117,3 @@ parsable <- function(x) { res <- try_silently(parse(text = x)) !inherits(res, "try-error") } - - -#' TODO comment linter -#' -#' Check that the source contains no TODO comments (case-insensitive). -#' -#' @param todo Vector of strings that identify TODO comments. -#' -#' @examples -#' # will produce lints -#' lint( -#' text = "x + y # TODO", -#' linters = todo_comment_linter() -#' ) -#' -#' lint( -#' text = "pi <- 1.0 # FIXME", -#' linters = todo_comment_linter() -#' ) -#' -#' lint( -#' text = "x <- TRUE # hack", -#' linters = todo_comment_linter(todo = c("todo", "fixme", "hack")) -#' ) -#' -#' # okay -#' lint( -#' text = "x + y # my informative comment", -#' linters = todo_comment_linter() -#' ) -#' -#' lint( -#' text = "pi <- 3.14", -#' linters = todo_comment_linter() -#' ) -#' -#' lint( -#' text = "x <- TRUE", -#' linters = todo_comment_linter() -#' ) -#' -#' @evalRd rd_tags("todo_comment_linter") -#' @seealso [linters] for a complete list of linters available in lintr. -#' @export -todo_comment_linter <- function(todo = c("todo", "fixme")) { - todo_comment_regex <- rex(one_or_more("#"), any_spaces, or(todo)) - Linter(function(source_expression) { - tokens <- with_id(source_expression, ids_with_token(source_expression, "COMMENT")) - are_todo <- re_matches(tokens[["text"]], todo_comment_regex, ignore.case = TRUE) - tokens <- tokens[are_todo, ] - lapply( - split(tokens, seq_len(nrow(tokens))), - function(token) { - Lint( - filename = source_expression[["filename"]], - line_number = token[["line1"]], - column_number = token[["col1"]], - type = "style", - message = "TODO comments should be removed.", - line = source_expression[["lines"]][[as.character(token[["line1"]])]], - ranges = list(c(token[["col1"]], token[["col2"]])) - ) - } - ) - }) -} diff --git a/R/comments.R b/R/comments.R deleted file mode 100644 index 5ada6e84f..000000000 --- a/R/comments.R +++ /dev/null @@ -1,116 +0,0 @@ -in_ci <- function() { - in_travis() || in_wercker() || in_jenkins() -} - -ci_type <- function() { - if (in_travis()) { - return("travis") - } - if (in_wercker()) { - return("wercker") - } - if (in_jenkins()) { - return("jenkins") - } - "" -} - -in_jenkins <- function() { - nzchar(Sys.getenv("JENKINS_URL")) && !is.null(jenkins_build_info()) -} - -jenkins_build_info <- function() { - git_url <- Sys.getenv("GIT_URL", Sys.getenv("GIT_URL_1", NA)) - if (is.na(git_url)) { - return(NULL) - } - - pattern <- "(https?:\\/\\/|git@)github\\.com[:\\/](.+\\/.+)\\.git" - if (!length(grep(pattern, git_url))) { - return(NULL) - } - slug <- gsub(pattern, "\\2", git_url) - - slug_info <- strsplit(slug, "/", fixed = TRUE)[[1L]] - - list( - user = slug_info[1L], - repo = slug_info[2L], - pull = Sys.getenv("CHANGE_ID", NA) %||% NULL, - commit = Sys.getenv("GIT_COMMIT", NA) %||% NULL - ) -} - -in_travis <- function() { - nzchar(Sys.getenv("TRAVIS_REPO_SLUG")) -} - -travis_build_info <- function() { - slug <- Sys.getenv("TRAVIS_REPO_SLUG") - slug_info <- strsplit(slug, "/", fixed = TRUE)[[1L]] - - list( - user = slug_info[1L] %||% "", - repo = slug_info[2L] %||% "", - pull = Sys.getenv("TRAVIS_PULL_REQUEST"), - branch = Sys.getenv("TRAVIS_BRANCH"), - commit = Sys.getenv("TRAVIS_COMMIT") - ) -} - -in_wercker <- function() { - nzchar(Sys.getenv("WERCKER_GIT_BRANCH")) -} - -ci_build_info <- function() { - type <- ci_type() - switch( - type, - travis = travis_build_info(), - wercker = wercker_build_info(), - jenkins = jenkins_build_info() - ) -} - -wercker_build_info <- function() { - list( - user = Sys.getenv("WERCKER_GIT_OWNER"), - repo = Sys.getenv("WERCKER_GIT_REPOSITORY"), - branch = Sys.getenv("WERCKER_GIT_BRANCH"), - commit = Sys.getenv("WERCKER_GIT_COMMIT") - ) -} - -# nocov start -github_comment <- function(text, info = NULL, token = settings$comment_token) { - if (!requireNamespace("httr", quietly = TRUE)) { - stop("Package 'httr' is required to post comments with github_comment().", call. = FALSE) - } - if (!requireNamespace("jsonlite", quietly = TRUE)) { - stop("Package 'jsonlite' is required to post comments with github_comment().", call. = FALSE) - } - - if (is.null(info)) { - info <- ci_build_info() - } - - if (!is.null(info$pull) && info$pull != "false") { - api_subdir <- file.path("issues", info$pull) - } else if (!is.null(info$commit)) { - api_subdir <- file.path("commits", info$commit) - } else { - stop("Expected a pull or a commit, but received ci_build_info() = ", format(info), call. = FALSE) - } - response <- httr::POST( - "https://api.github.com", - path = file.path("repos", info$user, info$repo, api_subdir, "comments"), - body = list(body = jsonlite::unbox(text)), - query = list(access_token = token), - encode = "json" - ) - - if (httr::status_code(response) >= 300L) { - message(httr::http_condition(response, "error", task = httr::content(response, as = "text"))) - } -} -# nocov end diff --git a/R/comparison_negation_linter.R b/R/comparison_negation_linter.R index a1c83eaa8..f2c3424ab 100644 --- a/R/comparison_negation_linter.R +++ b/R/comparison_negation_linter.R @@ -62,7 +62,6 @@ comparison_negation_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) diff --git a/R/condition_call_linter.R b/R/condition_call_linter.R index 1a618d8ba..8b13c8a92 100644 --- a/R/condition_call_linter.R +++ b/R/condition_call_linter.R @@ -6,10 +6,10 @@ #' #' @param display_call Logical specifying expected behaviour regarding `call.` #' argument in conditions. -#' - `NA` forces providing `call.=` but ignores its value (this can be used in +#' - `NA` forces providing `call. =` but ignores its value (this can be used in #' cases where you expect a mix of `call. = FALSE` and `call. = TRUE`) -#' - lints `call. = FALSE` -#' - forces `call. = FALSE` (lints `call. = TRUE` or missing `call.=` value) +#' - `TRUE` lints `call. = FALSE` +#' - `FALSE` forces `call. = FALSE` (lints `call. = TRUE` or missing `call. =` value) #' #' #' @examples @@ -58,58 +58,35 @@ condition_call_linter <- function(display_call = FALSE) { call_xpath <- glue::glue(" following-sibling::SYMBOL_SUB[text() = 'call.'] - /following-sibling::expr[1] - /NUM_CONST[text() = '{!display_call}'] + /following-sibling::expr[1] + /NUM_CONST[text() = '{!display_call}'] ") - no_call_xpath <- " - parent::expr[ - count(SYMBOL_SUB[text() = 'call.']) = 0 - ] - " + no_call_xpath <- "parent::expr[not(SYMBOL_SUB[text() = 'call.'])]" if (is.na(display_call)) { - frag <- no_call_xpath + call_cond <- no_call_xpath + msg_fmt <- "Provide an explicit value for `call.` in %s()." } else if (display_call) { - frag <- call_xpath + call_cond <- call_xpath + msg_fmt <- "Use %s(.) to display the call in an error message." } else { # call. = TRUE can be expressed in two way: # - either explicitly with call. = TRUE # - or by implicitly relying on the default - frag <- xp_or(call_xpath, no_call_xpath) + call_cond <- xp_or(call_xpath, no_call_xpath) + msg_fmt <- "Use %s(., call. = FALSE) not to display the call in an error message." } - xpath <- glue::glue(" - //SYMBOL_FUNCTION_CALL[text() = 'stop' or text() = 'warning'] - /parent::expr[{frag}] - /parent::expr - ") + xpath <- glue::glue("parent::expr[{call_cond}]/parent::expr") Linter(linter_level = "expression", function(source_expression) { - - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) - - if (is.na(display_call)) { - msg <- glue::glue( - "Provide an explicit value for call. in {xp_call_name(bad_expr)}()." - ) - } else if (display_call) { - msg <- glue::glue( - "Use {xp_call_name(bad_expr)}(.) to display call in error message." - ) - } else { - msg <- glue::glue( - "Use {xp_call_name(bad_expr)}(., call. = FALSE)", - " to not display call in error message." - ) - } + xml_calls <- source_expression$xml_find_function_calls(c("stop", "warning")) + bad_expr <- xml_find_all(xml_calls, xpath) xml_nodes_to_lints( bad_expr, source_expression = source_expression, - lint_message = msg, + lint_message = sprintf(msg_fmt, xp_call_name(bad_expr)), type = "warning" ) }) diff --git a/R/condition_message_linter.R b/R/condition_message_linter.R index 1004f5161..e20e53b4b 100644 --- a/R/condition_message_linter.R +++ b/R/condition_message_linter.R @@ -44,9 +44,8 @@ condition_message_linter <- function() { translators <- c("packageStartupMessage", "message", "warning", "stop") xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ - ({xp_text_in_table(translators)}) - and not(preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT) + self::SYMBOL_FUNCTION_CALL[ + not(preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT) ] /parent::expr /following-sibling::expr[ @@ -57,10 +56,8 @@ condition_message_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(translators) + bad_expr <- xml_find_all(xml_calls, xpath) sep_value <- get_r_string(bad_expr, xpath = "./expr/SYMBOL_SUB[text() = 'sep']/following-sibling::expr/STR_CONST") bad_expr <- bad_expr[is.na(sep_value) | sep_value %in% c("", " ")] diff --git a/R/conjunct_test_linter.R b/R/conjunct_test_linter.R index 92f3d51a8..5b4b0ca2b 100644 --- a/R/conjunct_test_linter.R +++ b/R/conjunct_test_linter.R @@ -79,30 +79,21 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE, allow_filter <- match.arg(allow_filter) expect_true_assert_that_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'assert_that'] - /parent::expr + parent::expr /following-sibling::expr[1][AND2] /parent::expr " named_stopifnot_condition <- if (allow_named_stopifnot) "and not(preceding-sibling::*[1][self::EQ_SUB])" else "" stopifnot_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'stopifnot'] - /parent::expr + parent::expr /following-sibling::expr[1][AND2 {named_stopifnot_condition}] /parent::expr ") expect_false_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_false'] - /parent::expr + parent::expr /following-sibling::expr[1][OR2] /parent::expr " - test_xpath <- paste( - expect_true_assert_that_xpath, - stopifnot_xpath, - expect_false_xpath, - sep = " | " - ) filter_ns_cond <- switch(allow_filter, never = "not(SYMBOL_PACKAGE[text() != 'dplyr'])", @@ -110,30 +101,33 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE, always = "true" ) filter_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'filter'] - /parent::expr[{ filter_ns_cond }] + parent::expr[{ filter_ns_cond }] /parent::expr /expr[AND] ") Linter(linter_level = "file", function(source_expression) { # need the full file to also catch usages at the top level - xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - - test_expr <- xml_find_all(xml, test_xpath) + expect_true_assert_that_calls <- source_expression$xml_find_function_calls(c("expect_true", "assert_that")) + stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot") + expect_false_calls <- source_expression$xml_find_function_calls("expect_false") + test_expr <- combine_nodesets( + xml_find_all(expect_true_assert_that_calls, expect_true_assert_that_xpath), + xml_find_all(stopifnot_calls, stopifnot_xpath), + xml_find_all(expect_false_calls, expect_false_xpath) + ) matched_fun <- xp_call_name(test_expr) operator <- xml_find_chr(test_expr, "string(expr/*[self::AND2 or self::OR2])") replacement_fmt <- ifelse( matched_fun %in% c("expect_true", "expect_false"), - "write multiple expectations like %1$s(A) and %1$s(B)", - "write multiple conditions like %s(A, B)." + "Write multiple expectations like %1$s(A) and %1$s(B)", + "Write multiple conditions like %s(A, B)" ) lint_message <- paste( - sprintf("Instead of %s(A %s B),", matched_fun, operator), # as.character() needed for 0-lint case where ifelse(logical(0)) returns logical(0) sprintf(as.character(replacement_fmt), matched_fun), + sprintf("instead of %s(A %s B).", matched_fun, operator), "The latter will produce better error messages in the case of failure." ) lints <- xml_nodes_to_lints( @@ -144,7 +138,8 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE, ) if (allow_filter != "always") { - filter_expr <- xml_find_all(xml, filter_xpath) + xml_calls <- source_expression$xml_find_function_calls("filter") + filter_expr <- xml_find_all(xml_calls, filter_xpath) filter_lints <- xml_nodes_to_lints( filter_expr, diff --git a/R/consecutive_assertion_linter.R b/R/consecutive_assertion_linter.R index 7f074f13b..668ed1593 100644 --- a/R/consecutive_assertion_linter.R +++ b/R/consecutive_assertion_linter.R @@ -31,28 +31,32 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export consecutive_assertion_linter <- function() { - xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'stopifnot'] - /parent::expr + # annoying expr-but-not-really nodes + next_expr <- "following-sibling::*[self::expr or self::expr_or_assign_or_help or self::equal_assign][1]" + + stopifnot_xpath <- glue(" + parent::expr /parent::expr[ - expr[1]/SYMBOL_FUNCTION_CALL = following-sibling::expr[1]/expr[1]/SYMBOL_FUNCTION_CALL + expr[1]/SYMBOL_FUNCTION_CALL = {next_expr}/expr[1]/SYMBOL_FUNCTION_CALL ] - | - //SYMBOL_FUNCTION_CALL[text() = 'assert_that'] - /parent::expr + ") + assert_that_xpath <- glue(" + parent::expr /parent::expr[ not(SYMBOL_SUB[text() = 'msg']) and not(following-sibling::expr[1]/SYMBOL_SUB[text() = 'msg']) - and expr[1]/SYMBOL_FUNCTION_CALL = following-sibling::expr[1]/expr[1]/SYMBOL_FUNCTION_CALL + and expr[1]/SYMBOL_FUNCTION_CALL = {next_expr}/expr[1]/SYMBOL_FUNCTION_CALL ] - " + ") Linter(linter_level = "file", function(source_expression) { # need the full file to also catch usages at the top level - xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot") + assert_that_calls <- source_expression$xml_find_function_calls("assert_that") + bad_expr <- combine_nodesets( + xml_find_all(stopifnot_calls, stopifnot_xpath), + xml_find_all(assert_that_calls, assert_that_xpath) + ) matched_function <- xp_call_name(bad_expr) xml_nodes_to_lints( diff --git a/R/consecutive_mutate_linter.R b/R/consecutive_mutate_linter.R index 40e061fe3..c84403ce0 100644 --- a/R/consecutive_mutate_linter.R +++ b/R/consecutive_mutate_linter.R @@ -37,12 +37,11 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export consecutive_mutate_linter <- function(invalid_backends = "dbplyr") { - attach_pkg_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] - /parent::expr + attach_pkg_xpath <- " + parent::expr /following-sibling::expr /*[self::SYMBOL or self::STR_CONST] - ") + " namespace_xpath <- glue(" //SYMBOL_PACKAGE[{ xp_text_in_table(invalid_backends) }] @@ -74,9 +73,11 @@ consecutive_mutate_linter <- function(invalid_backends = "dbplyr") { Linter(linter_level = "file", function(source_expression) { # need the full file to also catch usages at the top level xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - attach_str <- get_r_string(xml_find_all(xml, attach_pkg_xpath)) + attach_str <- get_r_string(xml_find_all( + source_expression$xml_find_function_calls(c("library", "require")), + attach_pkg_xpath + )) if (any(invalid_backends %in% attach_str)) { return(list()) } diff --git a/R/cyclocomp_linter.R b/R/cyclocomp_linter.R index 7288ff07c..c5563646f 100644 --- a/R/cyclocomp_linter.R +++ b/R/cyclocomp_linter.R @@ -36,8 +36,8 @@ cyclocomp_linter <- function(complexity_limit = 15L) { column_number = source_expression[["column"]][1L], type = "style", message = sprintf( - "Functions should have cyclomatic complexity of less than %d, this has %d.", - complexity_limit, complexity + "Reduce the cyclomatic complexity of this function from %d to at most %d.", + complexity, complexity_limit ), ranges = list(rep(col1, 2L)), line = source_expression$lines[1L] diff --git a/R/duplicate_argument_linter.R b/R/duplicate_argument_linter.R index edcb673ab..d4241b299 100644 --- a/R/duplicate_argument_linter.R +++ b/R/duplicate_argument_linter.R @@ -37,28 +37,33 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export duplicate_argument_linter <- function(except = c("mutate", "transmute")) { - xpath_call_with_args <- "//EQ_SUB/parent::expr" - xpath_arg_name <- "./EQ_SUB/preceding-sibling::*[1]" + # NB: approach checking for duplicates in XPath is hard because of + # quoted names, e.g. foo(a = 1, `a` = 2), so compute duplicates in R + xpath_call_with_args <- glue(" + //EQ_SUB[not( + preceding-sibling::expr/SYMBOL_FUNCTION_CALL[{ xp_text_in_table(except) }] + )] + /parent::expr[count(EQ_SUB) > 1] + ") + xpath_arg_name <- "./EQ_SUB/preceding-sibling::*[not(self::COMMENT)][1]" Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - calls <- xml_find_all(xml, xpath_call_with_args) + call_expr <- xml_find_all(xml, xpath_call_with_args) - if (length(except) > 0L) { - calls_text <- get_r_string(xp_call_name(calls)) - calls <- calls[!(calls_text %in% except)] - } - - all_arg_nodes <- lapply(calls, xml_find_all, xpath_arg_name) - arg_names <- lapply(all_arg_nodes, get_r_string) - is_duplicated <- lapply(arg_names, duplicated) + bad_expr <- lapply( + call_expr, + function(expr) { + arg_expr <- xml_find_all(expr, xpath_arg_name) + arg_expr[duplicated(get_r_string(arg_expr))] + } + ) xml_nodes_to_lints( - unlist(all_arg_nodes, recursive = FALSE)[unlist(is_duplicated)], + unlist(bad_expr, recursive = FALSE), source_expression = source_expression, - lint_message = "Duplicate arguments in function call.", + lint_message = "Avoid duplicate arguments in function calls.", type = "warning" ) }) diff --git a/R/equals_na_linter.R b/R/equals_na_linter.R index 8f9084f9d..2961ac984 100644 --- a/R/equals_na_linter.R +++ b/R/equals_na_linter.R @@ -48,14 +48,14 @@ equals_na_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) + op <- xml_find_first(bad_expr, "EQ | NE | SPECIAL") xml_nodes_to_lints( bad_expr, source_expression, - lint_message = "Use is.na for comparisons to NA (not == or != or %in%)", + lint_message = sprintf("Use is.na() instead of x %s NA", xml_text(op)), type = "warning" ) }) diff --git a/R/expect_comparison_linter.R b/R/expect_comparison_linter.R index b4ef31934..87dc24169 100644 --- a/R/expect_comparison_linter.R +++ b/R/expect_comparison_linter.R @@ -51,9 +51,8 @@ expect_comparison_linter <- function() { # != doesn't have a clean replacement comparator_nodes <- setdiff(infix_metadata$xml_tag[infix_metadata$comparator], "NE") xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr - /following-sibling::expr[ {xp_or(comparator_nodes)} ] + parent::expr + /following-sibling::expr[1][ {xp_or(comparator_nodes)} ] /parent::expr[not(SYMBOL_SUB[text() = 'info'])] ") @@ -64,10 +63,8 @@ expect_comparison_linter <- function() { ) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("expect_true") + bad_expr <- xml_find_all(xml_calls, xpath) comparator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])") expectation <- comparator_expectation_map[comparator] diff --git a/R/expect_identical_linter.R b/R/expect_identical_linter.R index 7a551a746..4ca6bf04a 100644 --- a/R/expect_identical_linter.R +++ b/R/expect_identical_linter.R @@ -61,8 +61,7 @@ expect_identical_linter <- function() { # where a numeric constant indicates inexact testing is preferable # - skip calls using dots (`...`); see tests expect_equal_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal'] - /parent::expr[not( + parent::expr[not( following-sibling::EQ_SUB or following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'c']] @@ -74,18 +73,18 @@ expect_identical_linter <- function() { /parent::expr " expect_true_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1]/SYMBOL_FUNCTION_CALL[text() = 'identical']] /parent::expr " - xpath <- paste(expect_equal_xpath, "|", expect_true_xpath) - Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + expect_equal_calls <- source_expression$xml_find_function_calls("expect_equal") + expect_true_calls <- source_expression$xml_find_function_calls("expect_true") + bad_expr <- c( + xml_find_all(expect_equal_calls, expect_equal_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) - bad_expr <- xml_find_all(xml, xpath) xml_nodes_to_lints( bad_expr, source_expression = source_expression, diff --git a/R/expect_length_linter.R b/R/expect_length_linter.R index 66626cdf0..a0cdc0e26 100644 --- a/R/expect_length_linter.R +++ b/R/expect_length_linter.R @@ -21,10 +21,9 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export expect_length_linter <- function() { - # TODO(michaelchirico): also catch expect_true(length(x) == 1) + # TODO(#2465): also catch expect_true(length(x) == 1) xpath <- sprintf(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'length']] and (position() = 1 or preceding-sibling::expr[NUM_CONST]) @@ -33,10 +32,9 @@ expect_length_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + bad_expr <- xml_find_all(xml_calls, xpath) - bad_expr <- xml_find_all(xml, xpath) matched_function <- xp_call_name(bad_expr) lint_message <- sprintf("expect_length(x, n) is better than %s(length(x), n)", matched_function) xml_nodes_to_lints(bad_expr, source_expression, lint_message, type = "warning") diff --git a/R/expect_lint.R b/R/expect_lint.R index 5aabe7856..2cc8e1f9e 100644 --- a/R/expect_lint.R +++ b/R/expect_lint.R @@ -25,16 +25,16 @@ #' expect_lint("a", NULL, trailing_blank_lines_linter()) #' #' # one expected lint -#' expect_lint("a\n", "superfluous", trailing_blank_lines_linter()) -#' expect_lint("a\n", list(message = "superfluous", line_number = 2), trailing_blank_lines_linter()) +#' expect_lint("a\n", "trailing blank", trailing_blank_lines_linter()) +#' expect_lint("a\n", list(message = "trailing blank", line_number = 2), trailing_blank_lines_linter()) #' #' # several expected lints -#' expect_lint("a\n\n", list("superfluous", "superfluous"), trailing_blank_lines_linter()) +#' expect_lint("a\n\n", list("trailing blank", "trailing blank"), trailing_blank_lines_linter()) #' expect_lint( #' "a\n\n", #' list( -#' list(message = "superfluous", line_number = 2), -#' list(message = "superfluous", line_number = 3) +#' list(message = "trailing blank", line_number = 2), +#' list(message = "trailing blank", line_number = 3) #' ), #' trailing_blank_lines_linter() #' ) diff --git a/R/expect_named_linter.R b/R/expect_named_linter.R index 802076fc8..26d83ceb2 100644 --- a/R/expect_named_linter.R +++ b/R/expect_named_linter.R @@ -32,8 +32,7 @@ #' @export expect_named_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'names']] and (position() = 1 or preceding-sibling::expr[STR_CONST]) @@ -42,10 +41,8 @@ expect_named_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + bad_expr <- xml_find_all(xml_calls, xpath) matched_function <- xp_call_name(bad_expr) lint_message <- sprintf("expect_named(x, n) is better than %s(names(x), n)", matched_function) diff --git a/R/expect_not_linter.R b/R/expect_not_linter.R index 5c68b80a2..04996d447 100644 --- a/R/expect_not_linter.R +++ b/R/expect_not_linter.R @@ -22,10 +22,10 @@ #' @evalRd rd_tags("expect_not_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -expect_not_linter <- make_linter_from_xpath( +expect_not_linter <- make_linter_from_function_xpath( + function_names = c("expect_true", "expect_false"), xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'expect_false'] - /parent::expr + parent::expr /following-sibling::expr[OP-EXCLAMATION] /parent::expr ", diff --git a/R/expect_null_linter.R b/R/expect_null_linter.R index 4f04e071d..10b15ff38 100644 --- a/R/expect_null_linter.R +++ b/R/expect_null_linter.R @@ -40,24 +40,24 @@ expect_null_linter <- function() { # (1) expect_{equal,identical}(x, NULL) (or NULL, x) # (2) expect_true(is.null(x)) expect_equal_identical_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[position() <= 2 and NULL_CONST] /parent::expr " expect_true_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1]/SYMBOL_FUNCTION_CALL[text() = 'is.null']] /parent::expr " - xpath <- paste(expect_equal_identical_xpath, "|", expect_true_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + expect_equal_identical_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + expect_true_calls <- source_expression$xml_find_function_calls("expect_true") - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- combine_nodesets( + xml_find_all(expect_equal_identical_calls, expect_equal_identical_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) matched_function <- xp_call_name(bad_expr) msg <- ifelse( diff --git a/R/expect_s3_class_linter.R b/R/expect_s3_class_linter.R index 3bd028f7c..7389b2abc 100644 --- a/R/expect_s3_class_linter.R +++ b/R/expect_s3_class_linter.R @@ -37,8 +37,7 @@ expect_s3_class_linter <- function() { # (1) expect_{equal,identical}(class(x), C) # (2) expect_true(is.(x)) and expect_true(inherits(x, C)) expect_equal_identical_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'class']] and (position() = 1 or preceding-sibling::expr[STR_CONST]) @@ -62,18 +61,19 @@ expect_s3_class_linter <- function() { )) is_class_call <- xp_text_in_table(c(is_s3_class_calls, "inherits")) expect_true_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[ {is_class_call} ]]] /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] ") - xpath <- paste(expect_equal_identical_xpath, "|", expect_true_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + expect_equal_identical_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + expect_true_calls <- source_expression$xml_find_function_calls("expect_true") - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- combine_nodesets( + xml_find_all(expect_equal_identical_calls, expect_equal_identical_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) matched_function <- xp_call_name(bad_expr) msg <- ifelse( matched_function %in% c("expect_equal", "expect_identical"), diff --git a/R/expect_s4_class_linter.R b/R/expect_s4_class_linter.R index 77ce252ed..61e839a97 100644 --- a/R/expect_s4_class_linter.R +++ b/R/expect_s4_class_linter.R @@ -26,20 +26,18 @@ expect_s4_class_linter <- function() { # require 2 expressions because methods::is(x) alone is a valid call, even # though the character output wouldn't make any sense for expect_true(). xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][count(expr) = 3 and expr[1][SYMBOL_FUNCTION_CALL[text() = 'is']]] /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - # TODO(michaelchirico): also catch expect_{equal,identical}(methods::is(x), k). + # TODO(#2423): also catch expect_{equal,identical}(methods::is(x), k). # this seems empirically rare, but didn't check many S4-heavy packages. - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("expect_true") + bad_expr <- xml_find_all(xml_calls, xpath) + xml_nodes_to_lints( bad_expr, source_expression = source_expression, diff --git a/R/expect_true_false_linter.R b/R/expect_true_false_linter.R index 8f7b384ed..c20eb393e 100644 --- a/R/expect_true_false_linter.R +++ b/R/expect_true_false_linter.R @@ -33,17 +33,14 @@ #' @export expect_true_false_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[position() <= 2 and NUM_CONST[text() = 'TRUE' or text() = 'FALSE']] /parent::expr " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + bad_expr <- xml_find_all(xml_calls, xpath) # NB: use expr/$node, not expr[$node], to exclude other things (especially ns:: parts of the call) call_name <- xp_call_name(bad_expr, condition = "starts-with(text(), 'expect_')") diff --git a/R/expect_type_linter.R b/R/expect_type_linter.R index 30174c6fd..6d669ed0b 100644 --- a/R/expect_type_linter.R +++ b/R/expect_type_linter.R @@ -43,8 +43,7 @@ expect_type_linter <- function() { ) base_type_tests <- xp_text_in_table(paste0("is.", base_types)) expect_equal_identical_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'typeof']] and (position() = 1 or preceding-sibling::expr[STR_CONST]) @@ -52,18 +51,18 @@ expect_type_linter <- function() { /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label' or text() = 'expected.label'])] " expect_true_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[ {base_type_tests} ]]] /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] ") - xpath <- paste(expect_equal_identical_xpath, "|", expect_true_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + expect_equal_identical_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + expect_true_calls <- source_expression$xml_find_function_calls("expect_true") + bad_expr <- combine_nodesets( + xml_find_all(expect_equal_identical_calls, expect_equal_identical_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) matched_function <- xp_call_name(bad_expr) msg <- ifelse( matched_function %in% c("expect_equal", "expect_identical"), diff --git a/R/extraction_operator_linter.R b/R/extraction_operator_linter.R deleted file mode 100644 index fe95630cb..000000000 --- a/R/extraction_operator_linter.R +++ /dev/null @@ -1,77 +0,0 @@ -#' Extraction operator linter -#' -#' Check that the `[[` operator is used when extracting a single element from an object, -#' not `[` (subsetting) nor `$` (interactive use). -#' -#' @details -#' -#' There are three subsetting operators in R (`[[`, `[`, and `$`) and they interact differently -#' with different data structures (atomic vector, list, data frame, etc.). -#' -#' Here are a few reasons to prefer the `[[` operator over `[` or `$` when you want to extract -#' an element from a data frame or a list: -#' -#' - Subsetting a list with `[` always returns a smaller list, while `[[` returns -#' the list element. -#' -#' - Subsetting a named atomic vector with `[` returns a named vector, while `[[` returns -#' the vector element. -#' -#' - Subsetting a data frame (but not tibble) with `[` is type unstable; it can return -#' a vector or a data frame. `[[`, on the other hand, always returns a vector. -#' -#' - For a data frame (but not tibble), `$` does partial matching (e.g. `df$a` will subset -#' `df$abc`), which can be a source of bugs. `[[` doesn't do partial matching. -#' -#' For data frames (and tibbles), irrespective of the size, the `[[` operator is slower than `$`. -#' For lists, however, the reverse is true. -#' -#' @examples -#' # will produce lints -#' lint( -#' text = 'iris["Species"]', -#' linters = extraction_operator_linter() -#' ) -#' -#' lint( -#' text = "iris$Species", -#' linters = extraction_operator_linter() -#' ) -#' -#' # okay -#' lint( -#' text = 'iris[["Species"]]', -#' linters = extraction_operator_linter() -#' ) -#' -#' @references -#' - Subsetting [chapter](https://adv-r.hadley.nz/subsetting.html) from _Advanced R_ (Wickham, 2019). -#' -#' @evalRd rd_tags("extraction_operator_linter") -#' @seealso [linters] for a complete list of linters available in lintr. -#' @export -extraction_operator_linter <- function() { - constant_nodes_in_brackets <- paste0("self::", c("expr", "OP-PLUS", "NUM_CONST", "STR_CONST")) - xpath <- glue(" - //OP-DOLLAR[not(preceding-sibling::expr[1]/SYMBOL[text() = 'self' or text() = '.self'])] - | - //OP-LEFT-BRACKET[ - not(following-sibling::expr[1]/descendant::*[not({xp_or(constant_nodes_in_brackets)})]) and - not(following-sibling::OP-COMMA) - ] - ") - - Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - bad_exprs <- xml_find_all(xml, xpath) - msgs <- sprintf("Use `[[` instead of `%s` to extract an element.", xml_text(bad_exprs)) - - xml_nodes_to_lints( - bad_exprs, - source_expression = source_expression, - lint_message = msgs, - type = "warning" - ) - }) -} diff --git a/R/fixed_regex_linter.R b/R/fixed_regex_linter.R index d124a3a18..d3a02fc50 100644 --- a/R/fixed_regex_linter.R +++ b/R/fixed_regex_linter.R @@ -76,12 +76,12 @@ #' @export fixed_regex_linter <- function(allow_unescaped = FALSE) { # regular expression pattern is the first argument - pos_1_regex_funs <- xp_text_in_table(c( + pos_1_regex_funs <- c( "grep", "gsub", "sub", "regexec", "grepl", "regexpr", "gregexpr" - )) + ) # regular expression pattern is the second argument - pos_2_regex_funs <- xp_text_in_table(c( + pos_2_regex_funs <- c( # base functions. "strsplit", # data.table functions. @@ -95,7 +95,7 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { "str_remove", "str_remove_all", "str_replace", "str_replace_all", "str_split", "str_starts", "str_subset", "str_view", "str_view_all", "str_which" - )) + ) pipes <- setdiff(magrittr_pipes, c("%$%", "%T>%")) in_pipe_cond <- glue(" @@ -105,9 +105,8 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { # NB: strsplit doesn't have an ignore.case argument # NB: we intentionally exclude cases like gsub(x, c("a" = "b")), where "b" is fixed - xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {pos_1_regex_funs} ] - /parent::expr[ + pos_1_xpath <- glue(" + parent::expr[ not(following-sibling::SYMBOL_SUB[ (text() = 'fixed' or text() = 'ignore.case') and following-sibling::expr[1][NUM_CONST[text() = 'TRUE'] or SYMBOL[text() = 'T']] @@ -124,9 +123,9 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { and preceding-sibling::*[2][self::SYMBOL_SUB/text() = 'pattern'] ) ] - | - //SYMBOL_FUNCTION_CALL[ {pos_2_regex_funs} ] - /parent::expr[ + ") + pos_2_xpath <- glue(" + parent::expr[ not(following-sibling::SYMBOL_SUB[ text() = 'fixed' and following-sibling::expr[1][NUM_CONST[text() = 'TRUE'] or SYMBOL[text() = 'T']] @@ -140,30 +139,34 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - patterns <- xml_find_all(xml, xpath) + pos_1_calls <- source_expression$xml_find_function_calls(pos_1_regex_funs) + pos_2_calls <- source_expression$xml_find_function_calls(pos_2_regex_funs) + patterns <- combine_nodesets( + xml_find_all(pos_1_calls, pos_1_xpath), + xml_find_all(pos_2_calls, pos_2_xpath) + ) pattern_strings <- get_r_string(patterns) + is_static <- is_not_regex(pattern_strings, allow_unescaped) + patterns <- patterns[is_static] + pattern_strings <- pattern_strings[is_static] - fixed_equivalent <- encodeString(get_fixed_string(pattern_strings[is_static]), quote = '"', justify = "none") - call_name <- xml_find_chr(patterns[is_static], "string(preceding-sibling::expr[last()]/SYMBOL_FUNCTION_CALL)") + fixed_equivalent <- encodeString(get_fixed_string(pattern_strings), quote = '"', justify = "none") + call_name <- xml_find_chr(patterns, "string(preceding-sibling::expr[last()]/SYMBOL_FUNCTION_CALL)") is_stringr <- startsWith(call_name, "str_") - replacement <- ifelse( + replacement_suggestion <- ifelse( is_stringr, - sprintf("stringr::fixed(%s)", fixed_equivalent), - fixed_equivalent + sprintf("stringr::fixed(%s) as the pattern", fixed_equivalent), + sprintf("%s with fixed = TRUE", fixed_equivalent) ) msg <- paste( - "This regular expression is static, i.e., its matches can be expressed as a fixed substring expression, which", - "is faster to compute. Here, you can use", - replacement, ifelse(is_stringr, "as the pattern.", "with fixed = TRUE.") + "Use", replacement_suggestion, "here. This regular expression is static, i.e.,", + "its matches can be expressed as a fixed substring expression, which is faster to compute." ) xml_nodes_to_lints( - patterns[is_static], + patterns, source_expression = source_expression, lint_message = msg, type = "warning" diff --git a/R/function_argument_linter.R b/R/function_argument_linter.R index 7268eac9a..921e002b2 100644 --- a/R/function_argument_linter.R +++ b/R/function_argument_linter.R @@ -61,7 +61,6 @@ function_argument_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) diff --git a/R/function_left_parentheses_linter.R b/R/function_left_parentheses_linter.R index 176e5f9ea..07e4ee438 100644 --- a/R/function_left_parentheses_linter.R +++ b/R/function_left_parentheses_linter.R @@ -59,7 +59,6 @@ function_left_parentheses_linter <- function() { # nolint: object_length. Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_line_fun_exprs <- xml_find_all(xml, bad_line_fun_xpath) bad_line_fun_lints <- xml_nodes_to_lints( diff --git a/R/function_return_linter.R b/R/function_return_linter.R index acd95af4d..4a51ecd30 100644 --- a/R/function_return_linter.R +++ b/R/function_return_linter.R @@ -55,10 +55,8 @@ #' @evalRd rd_tags("function_return_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -function_return_linter <- make_linter_from_xpath( - xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'return'] - /parent::expr/parent::expr/expr[LEFT_ASSIGN or RIGHT_ASSIGN] - ", +function_return_linter <- make_linter_from_function_xpath( + function_names = "return", + xpath = "parent::expr/parent::expr/expr[LEFT_ASSIGN or RIGHT_ASSIGN]", lint_message = "Move the assignment outside of the return() clause, or skip assignment altogether." ) diff --git a/R/get_source_expressions.R b/R/get_source_expressions.R index 349b80b99..bc83712d5 100644 --- a/R/get_source_expressions.R +++ b/R/get_source_expressions.R @@ -18,41 +18,47 @@ #' \describe{ #' \item{expressions}{a `list` of #' `n+1` objects. The first `n` elements correspond to each expression in -#' `filename`, and consist of a list of 9 elements: +#' `filename`, and consist of a list of 8 elements: #' \itemize{ -#' \item{`filename` (`character`)} -#' \item{`line` (`integer`) the line in `filename` where this expression begins} -#' \item{`column` (`integer`) the column in `filename` where this expression begins} +#' \item{`filename` (`character`) the name of the file.} +#' \item{`line` (`integer`) the line in the file where this expression begins.} +#' \item{`column` (`integer`) the column in the file where this expression begins.} #' \item{`lines` (named `character`) vector of all lines spanned by this -#' expression, named with the line number corresponding to `filename`} -#' \item{`parsed_content` (`data.frame`) as given by [utils::getParseData()] for this expression} -#' \item{`xml_parsed_content` (`xml_document`) the XML parse tree of this -#' expression as given by [xmlparsedata::xml_parse_data()]} -#' \item{`content` (`character`) the same as `lines` as a single string (not split across lines)} +#' expression, named with the corresponding line numbers.} +#' \item{`parsed_content` (`data.frame`) as given by [utils::getParseData()] for this expression.} +#' \item{`xml_parsed_content` (`xml_document`) the XML parse tree of this expression as given by +#' [xmlparsedata::xml_parse_data()].} +#' \item{`content` (`character`) the same as `lines` as a single string (not split across lines).} +#' \item{`xml_find_function_calls(function_names)` (`function`) a function that returns all `SYMBOL_FUNCTION_CALL` +#' XML nodes from `xml_parsed_content` with specified function names.} #' } #' #' The final element of `expressions` is a list corresponding to the full file -#' consisting of 6 elements: +#' consisting of 7 elements: #' \itemize{ -#' \item{`filename` (`character`)} -#' \item{`file_lines` (`character`) the [readLines()] output for this file} +#' \item{`filename` (`character`) the name of this file.} +#' \item{`file_lines` (`character`) the [readLines()] output for this file.} #' \item{`content` (`character`) for .R files, the same as `file_lines`; -#' for .Rmd or .qmd scripts, this is the extracted R source code (as text)} +#' for .Rmd or .qmd scripts, this is the extracted R source code (as text).} #' \item{`full_parsed_content` (`data.frame`) as given by -#' [utils::getParseData()] for the full content} +#' [utils::getParseData()] for the full content.} #' \item{`full_xml_parsed_content` (`xml_document`) the XML parse tree of all -#' expressions as given by [xmlparsedata::xml_parse_data()]} +#' expressions as given by [xmlparsedata::xml_parse_data()].} #' \item{`terminal_newline` (`logical`) records whether `filename` has a terminal -#' newline (as determined by [readLines()] producing a corresponding warning)} +#' newline (as determined by [readLines()] producing a corresponding warning).} +#' \item{`xml_find_function_calls(function_names)` (`function`) a function that returns all `SYMBOL_FUNCTION_CALL` +#' XML nodes from `full_xml_parsed_content` with specified function names.} #' } #' } #' \item{error}{A `Lint` object describing any parsing error.} #' \item{lines}{The [readLines()] output for this file.} #' } #' -#' @examplesIf requireNamespace("withr", quietly = TRUE) -#' tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1")) +#' @examples +#' tmp <- tempfile() +#' writeLines(c("x <- 1", "y <- x + 1"), tmp) #' get_source_expressions(tmp) +#' unlink(tmp) #' @export get_source_expressions <- function(filename, lines = NULL) { source_expression <- srcfile(filename, encoding = settings$encoding) @@ -103,6 +109,7 @@ get_source_expressions <- function(filename, lines = NULL) { ) for (i in seq_along(expressions)) { expressions[[i]]$xml_parsed_content <- expression_xmls[[i]] + expressions[[i]]$xml_find_function_calls <- build_xml_find_function_calls(expression_xmls[[i]]) } } @@ -113,6 +120,7 @@ get_source_expressions <- function(filename, lines = NULL) { content = source_expression$lines, full_parsed_content = parsed_content, full_xml_parsed_content = xml_parsed_content, + xml_find_function_calls = build_xml_find_function_calls(xml_parsed_content), terminal_newline = terminal_newline ) } @@ -476,6 +484,8 @@ get_single_source_expression <- function(loc, lines = expr_lines, parsed_content = pc, xml_parsed_content = xml2::xml_missing(), + # Placeholder for xml_find_function_calls, if needed (e.g. on R <= 4.0.5 with input source "\\") + xml_find_function_calls = build_xml_find_function_calls(xml2::xml_missing()), content = content ) } @@ -632,18 +642,7 @@ fix_eq_assigns <- function(pc) { for (i in seq_len(n_expr)) { start_loc <- true_locs[i] - - # TODO(michaelchirico): vectorize this loop away. the tricky part is, - # this loop doesn't execute on most R versions (we tried 3.6.3 and 4.2.0). - # so it likely requires some GHA print debugging -- tedious :) end_loc <- true_locs[i] - j <- end_loc + 1L - # nocov start: only runs on certain R versions - while (j <= length(expr_locs) && !expr_locs[j]) { - end_loc <- j - j <- j + 1L - } - # nocov end prev_loc <- prev_locs[start_loc] next_loc <- next_locs[end_loc] diff --git a/R/ids_with_token.R b/R/ids_with_token.R index 9518b4272..69b04a578 100644 --- a/R/ids_with_token.R +++ b/R/ids_with_token.R @@ -17,11 +17,13 @@ #' the `token` column of `parsed_content`. Typically `==` or `%in%`. #' @param source_file (DEPRECATED) Same as `source_expression`. Will be removed. #' -#' @examplesIf requireNamespace("withr", quietly = TRUE) -#' tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1")) +#' @examples +#' tmp <- tempfile() +#' writeLines(c("x <- 1", "y <- x + 1"), tmp) #' source_exprs <- get_source_expressions(tmp) #' ids_with_token(source_exprs$expressions[[1L]], value = "SYMBOL") #' with_id(source_exprs$expressions[[1L]], 2L) +#' unlink(tmp) #' #' @return `ids_with_token`: The indices of the `parsed_content` data frame #' entry of the list of source expressions. Indices correspond to the diff --git a/R/if_not_else_linter.R b/R/if_not_else_linter.R index 731ca4625..758ba2102 100644 --- a/R/if_not_else_linter.R +++ b/R/if_not_else_linter.R @@ -71,8 +71,7 @@ if_not_else_linter <- function(exceptions = c("is.null", "is.na", "missing")) { ") ifelse_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /parent::expr[expr[ position() = 2 and OP-EXCLAMATION @@ -85,20 +84,17 @@ if_not_else_linter <- function(exceptions = c("is.null", "is.na", "missing")) { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs) if_expr <- xml_find_all(xml, if_xpath) if_lints <- xml_nodes_to_lints( if_expr, source_expression = source_expression, - lint_message = paste( - "In a simple if/else statement,", - "prefer `if (A) x else y` to the less-readable `if (!A) y else x`." - ), + lint_message = "Prefer `if (A) x else y` to the less-readable `if (!A) y else x` in a simple if/else statement.", type = "warning" ) - ifelse_expr <- xml_find_all(xml, ifelse_xpath) + ifelse_expr <- xml_find_all(ifelse_calls, ifelse_xpath) ifelse_call <- xp_call_name(ifelse_expr) ifelse_lints <- xml_nodes_to_lints( ifelse_expr, diff --git a/R/if_switch_linter.R b/R/if_switch_linter.R index 0d21dd209..89415ed94 100644 --- a/R/if_switch_linter.R +++ b/R/if_switch_linter.R @@ -14,6 +14,12 @@ #' approach is roughly linear in the number of conditions that need to #' be evaluated, here up to 3 times). #' +#' @param max_branch_lines,max_branch_expressions Integer, default 0 indicates "no maximum". +#' If set any `if`/`else if`/.../`else` chain where any branch occupies more than +#' this number of lines (resp. expressions) will not be linted. The conjugate +#' applies to `switch()` statements -- if these parameters are set, any `switch()` +#' statement with any overly-complicated branches will be linted. See examples. +#' #' @examples #' # will produce lints #' lint( @@ -21,6 +27,64 @@ #' linters = if_switch_linter() #' ) #' +#' code <- paste( +#' "if (x == 'a') {", +#' " 1", +#' "} else if (x == 'b') {", +#' " 2", +#' "} else if (x == 'c') {", +#' " y <- x", +#' " z <- sqrt(match(y, letters))", +#' " z", +#' "}", +#' sep = "\n" +#' ) +#' writeLines(code) +#' lint( +#' text = code, +#' linters = if_switch_linter() +#' ) +#' +#' code <- paste( +#' "if (x == 'a') {", +#' " 1", +#' "} else if (x == 'b') {", +#' " 2", +#' "} else if (x == 'c') {", +#' " y <- x", +#' " z <- sqrt(", +#' " match(y, letters)", +#' " )", +#' " z", +#' "}", +#' sep = "\n" +#' ) +#' writeLines(code) +#' lint( +#' text = code, +#' linters = if_switch_linter() +#' ) +#' +#' code <- paste( +#' "switch(x,", +#' " a = {", +#' " 1", +#' " 2", +#' " 3", +#' " },", +#' " b = {", +#' " 1", +#' " 2", +#' " }", +#' ")", +#' sep = "\n" +#' ) +#' writeLines(code) +#' lint( +#' text = code, +#' linters = if_switch_linter(max_branch_lines = 2L) +#' ) +#' #' # okay #' lint( #' text = "switch(x, a = 1, b = 2, 3)", @@ -33,18 +97,105 @@ #' linters = if_switch_linter() #' ) #' +#' code <- paste( +#' "if (x == 'a') {", +#' " 1", +#' "} else if (x == 'b') {", +#' " 2", +#' "} else if (x == 'c') {", +#' " y <- x", +#' " z <- sqrt(match(y, letters))", +#' " z", +#' "}", +#' sep = "\n" +#' ) +#' writeLines(code) +#' lint( +#' text = code, +#' linters = if_switch_linter(max_branch_lines = 2L) +#' ) +#' +#' code <- paste( +#' "if (x == 'a') {", +#' " 1", +#' "} else if (x == 'b') {", +#' " 2", +#' "} else if (x == 'c') {", +#' " y <- x", +#' " z <- sqrt(", +#' " match(y, letters)", +#' " )", +#' " z", +#' "}", +#' sep = "\n" +#' ) +#' writeLines(code) +#' lint( +#' text = code, +#' linters = if_switch_linter(max_branch_expressions = 2L) +#' ) +#' +#' code <- paste( +#' "switch(x,", +#' " a = {", +#' " 1", +#' " 2", +#' " 3", +#' " },", +#' " b = {", +#' " 1", +#' " 2", +#' " }", +#' ")", +#' sep = "\n" +#' ) +#' writeLines(code) +#' lint( +#' text = code, +#' linters = if_switch_linter(max_branch_lines = 3L) +#' ) +#' #' @evalRd rd_tags("if_switch_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -if_switch_linter <- function() { - equal_str_cond <- "expr[1][EQ and expr[STR_CONST]]" +if_switch_linter <- function(max_branch_lines = 0L, max_branch_expressions = 0L) { + equal_str_cond <- "expr[1][EQ and expr/STR_CONST]" + + if (max_branch_lines > 0L || max_branch_expressions > 0L) { + complexity_cond <- xp_or(c( + if (max_branch_lines > 0L) paste("OP-RIGHT-BRACE/@line2 - OP-LEFT-BRACE/@line1 > 1 +", max_branch_lines), + if (max_branch_expressions > 0L) paste("count(expr) >", max_branch_expressions) + )) + branch_expr_cond <- xp_and(c( + xp_or( + # if (x) { } ... + xp_and("preceding-sibling::IF", "position() = 2"), + # if (x) { ... } else { } + xp_and("preceding-sibling::ELSE", "not(IF)") + ), + complexity_cond + )) + max_lines_cond <- glue(".//expr[{branch_expr_cond}]") + + switch_xpath <- glue(" + parent::expr + /parent::expr[expr[ + position() > 2 + and {complexity_cond} + ]] + ") + } else { + max_lines_cond <- "false" + + switch_xpath <- NULL + } # NB: IF AND {...} AND ELSE/... implies >= 3 equality conditions are present # .//expr/IF/...: the expr in `==` that's _not_ the STR_CONST # not(preceding::IF): prevent nested matches which might be incorrect globally # not(. != .): don't match if there are _any_ expr which _don't_ match the top # expr - xpath <- glue(" + if_xpath <- glue(" //IF /parent::expr[ not(preceding-sibling::IF) @@ -58,16 +209,16 @@ if_switch_linter <- function() { .//expr/IF/following-sibling::{equal_str_cond}/expr[not(STR_CONST)] != expr[1][EQ]/expr[not(STR_CONST)] ) + and not({ max_lines_cond }) ] ") Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- xml_find_all(xml, if_xpath) - xml_nodes_to_lints( + lints <- xml_nodes_to_lints( bad_expr, source_expression = source_expression, lint_message = paste( @@ -77,5 +228,19 @@ if_switch_linter <- function() { ), type = "warning" ) + + if (!is.null(switch_xpath)) { + xml_calls <- source_expression$xml_find_function_calls("switch") + switch_expr <- xml_find_all(xml_calls, switch_xpath) + + lints <- c(lints, xml_nodes_to_lints( + switch_expr, + source_expression = source_expression, + lint_message = "Prefer repeated if/else statements over overly-complicated switch() statements.", + type = "warning" + )) + } + + lints }) } diff --git a/R/ifelse_censor_linter.R b/R/ifelse_censor_linter.R index 11bd7dd7e..c43d390e2 100644 --- a/R/ifelse_censor_linter.R +++ b/R/ifelse_censor_linter.R @@ -36,8 +36,7 @@ #' @export ifelse_censor_linter <- function() { xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /following-sibling::expr[ (LT or GT or LE or GE) and expr[1] = following-sibling::expr @@ -47,10 +46,8 @@ ifelse_censor_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs) + bad_expr <- xml_find_all(ifelse_calls, xpath) matched_call <- xp_call_name(bad_expr) operator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])") diff --git a/R/implicit_assignment_linter.R b/R/implicit_assignment_linter.R index c62960c57..70dfd3376 100644 --- a/R/implicit_assignment_linter.R +++ b/R/implicit_assignment_linter.R @@ -102,22 +102,25 @@ implicit_assignment_linter <- function(except = c("bquote", "expression", "expr" ) } + implicit_message <- paste( + "Avoid implicit assignments in function calls.", + "For example, instead of `if (x <- 1L) { ... }`, write `x <- 1L; if (x) { ... }`." + ) + + print_message <- "Call print() explicitly instead of relying on implicit printing behavior via '('." + Linter(linter_level = "file", function(source_expression) { # need the full file to also catch usages at the top level xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) - lint_message <- paste( - "Avoid implicit assignments in function calls.", - "For example, instead of `if (x <- 1L) { ... }`, write `x <- 1L; if (x) { ... }`." - ) + print_only <- !is.na(xml_find_first(bad_expr, "parent::expr[parent::exprlist and *[1][self::OP-LEFT-PAREN]]")) xml_nodes_to_lints( bad_expr, source_expression = source_expression, - lint_message = lint_message, + lint_message = ifelse(print_only, print_message, implicit_message), type = "warning" ) }) diff --git a/R/implicit_integer_linter.R b/R/implicit_integer_linter.R index 354120e6a..49e57c52e 100644 --- a/R/implicit_integer_linter.R +++ b/R/implicit_integer_linter.R @@ -53,14 +53,21 @@ implicit_integer_linter <- function(allow_colon = FALSE) { } Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - numbers <- xml_find_all(xml, xpath) + number_expr <- xml_find_all(xml, xpath) + number <- xml_text(number_expr) + lint_idx <- is_implicit_integer(number) + number_expr <- number_expr[lint_idx] + number <- number[lint_idx] + is_negative <- !is.na(xml_find_first(number_expr, "parent::expr/preceding-sibling::OP-MINUS")) + + lint_message <- + sprintf("Use %1$dL or %1$d.0 to avoid implicit integers.", ((-1L) ^ is_negative) * as.integer(number)) xml_nodes_to_lints( - numbers[is_implicit_integer(xml_text(numbers))], + number_expr, source_expression = source_expression, - lint_message = "Integers should not be implicit. Use the form 1L for integers or 1.0 for doubles.", + lint_message = lint_message, type = "style", column_number_xpath = "number(./@col2 + 1)", # mark at end range_end_xpath = "number(./@col2 + 1)" # end after number for easy fixing (enter "L" or ".0") diff --git a/R/indentation_linter.R b/R/indentation_linter.R index 066f19899..f5496d0a7 100644 --- a/R/indentation_linter.R +++ b/R/indentation_linter.R @@ -213,7 +213,7 @@ indentation_linter <- function(indent = 2L, hanging_indent_style = c("tidy", "al # will have "# comment" as a separate expression xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) + # Indentation increases by 1 for: # - { } blocks that span multiple lines # - ( ), [ ], or [[ ]] calls that span multiple lines @@ -292,8 +292,7 @@ indentation_linter <- function(indent = 2L, hanging_indent_style = c("tidy", "al type = "style", message = lint_messages, line = unname(source_expression$file_lines[bad_lines]), - # TODO(AshesITR) when updating supported R version to R >= 4.1: - # replace by ranges = apply(lint_ranges, 1L, list, simplify = FALSE) + # TODO(#2467): Use ranges = apply(lint_ranges, 1L, list, simplify = FALSE). ranges = lapply( seq_along(bad_lines), function(i) { diff --git a/R/infix_spaces_linter.R b/R/infix_spaces_linter.R index 13b3c4cc9..c7fa7bb1b 100644 --- a/R/infix_spaces_linter.R +++ b/R/infix_spaces_linter.R @@ -107,7 +107,7 @@ infix_spaces_linter <- function(exclude_operators = NULL, allow_multiple_spaces Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + bad_expr <- xml_find_all(xml, xpath) xml_nodes_to_lints( diff --git a/R/inner_combine_linter.R b/R/inner_combine_linter.R index fddd15fd8..b83a120a3 100644 --- a/R/inner_combine_linter.R +++ b/R/inner_combine_linter.R @@ -36,10 +36,7 @@ inner_combine_linter <- function() { "sqrt", "abs" ) - # TODO(michaelchirico): the need to spell out specific arguments is pretty brittle, - # but writing the xpath for the alternative case was proving too tricky. - # It's messy enough as is -- it may make sense to take another pass at - # writing the xpath from scratch to see if it can't be simplified. + # TODO(#2468): Try and make this XPath less brittle/more extensible. # See ?as.Date, ?as.POSIXct. tryFormats is not explicitly in any default # POSIXct method, but it is in as.Date.character and as.POSIXlt.character -- @@ -77,17 +74,14 @@ inner_combine_linter <- function() { lubridate_args_cond ) xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'c'] - /parent::expr[count(following-sibling::expr) > 1] + parent::expr[count(following-sibling::expr) > 1] /following-sibling::expr[1][ {c_expr_cond} ] /parent::expr ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("c") + bad_expr <- xml_find_all(xml_calls, xpath) matched_call <- xp_call_name(bad_expr, depth = 2L) lint_message <- paste( diff --git a/R/is_lint_level.R b/R/is_lint_level.R index d850c51cf..38d96d9ba 100644 --- a/R/is_lint_level.R +++ b/R/is_lint_level.R @@ -9,13 +9,15 @@ #' means an individual expression, while `"file"` means all expressions #' in the current file are available. #' -#' @examplesIf requireNamespace("withr", quietly = TRUE) -#' tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1")) +#' @examples +#' tmp <- tempfile() +#' writeLines(c("x <- 1", "y <- x + 1"), tmp) #' source_exprs <- get_source_expressions(tmp) #' is_lint_level(source_exprs$expressions[[1L]], level = "expression") #' is_lint_level(source_exprs$expressions[[1L]], level = "file") #' is_lint_level(source_exprs$expressions[[3L]], level = "expression") #' is_lint_level(source_exprs$expressions[[3L]], level = "file") +#' unlink(tmp) #' #' @export is_lint_level <- function(source_expression, level = c("expression", "file")) { diff --git a/R/is_numeric_linter.R b/R/is_numeric_linter.R index e75ba5472..ed7f35309 100644 --- a/R/is_numeric_linter.R +++ b/R/is_numeric_linter.R @@ -34,11 +34,9 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export is_numeric_linter <- function() { - # TODO(michaelchirico): this should also cover is.double(x) || is.integer(x) - # TODO(#1636): is.numeric(x) || is.integer(x) || is.factor(x) is also redundant - # TODO(michaelchirico): consdier capturing any(class(x) == "numeric/integer") - # here directly; currently we rely on class_equals_linter() also active - # TODO(michaelchirico): also catch inherits(x, c("numeric", "integer")) + # TODO(#2469): This should also cover is.double(x) || is.integer(x). + # TODO(#1636): is.numeric(x) || is.integer(x) || is.factor(x) is also redundant. + # TODO(#2470): Consider usages with class(), typeof(), or inherits(). is_numeric_expr <- "expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.numeric']]" is_integer_expr <- "expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.integer']]" @@ -55,7 +53,6 @@ is_numeric_linter <- function() { ") # testing class(x) %in% c("numeric", "integer") - # TODO(michaelchirico): include typeof(x) %in% c("integer", "double") class_xpath <- " //SPECIAL[ text() = '%in%' @@ -71,14 +68,13 @@ is_numeric_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) or_expr <- xml_find_all(xml, or_xpath) or_lints <- xml_nodes_to_lints( or_expr, source_expression = source_expression, lint_message = paste( - "is.numeric(x) is the same as is.numeric(x) || is.integer(x).", + "Use `is.numeric(x)` instead of the equivalent `is.numeric(x) || is.integer(x)`.", "Use is.double(x) to test for objects stored as 64-bit floating point." ), type = "warning" @@ -97,7 +93,7 @@ is_numeric_linter <- function() { class_expr, source_expression = source_expression, lint_message = paste( - 'is.numeric(x) is the same as class(x) %in% c("integer", "numeric").', + 'Use is.numeric(x) instead of class(x) %in% c("integer", "numeric").', "Use is.double(x) to test for objects stored as 64-bit floating point." ), type = "warning" diff --git a/R/keyword_quote_linter.R b/R/keyword_quote_linter.R index cdf7292be..6ebad5e40 100644 --- a/R/keyword_quote_linter.R +++ b/R/keyword_quote_linter.R @@ -46,11 +46,6 @@ #' @evalRd rd_tags("keyword_quote_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -# TODO(michaelchirico): offer a stricter version of this that -# requires backticks to be used for non-syntactic names (i.e., not quotes). -# Here are the relevant xpaths: -# //expr[expr[SYMBOL_FUNCTION_CALL]]/SYMBOL_SUB[starts-with(text(), '`')] -# //expr[expr[SYMBOL_FUNCTION_CALL]]/STR_CONST[{is_quoted(text())}] keyword_quote_linter <- function() { # Check if a string could be assigned as an R variable. # @@ -68,8 +63,7 @@ keyword_quote_linter <- function() { ) # SYMBOL_SUB for backticks, STR_CONST for quoted names call_arg_xpath <- glue(" - //SYMBOL_FUNCTION_CALL - /parent::expr + parent::expr /parent::expr /*[(self::SYMBOL_SUB or self::STR_CONST) and {quote_cond}] ") @@ -96,9 +90,9 @@ keyword_quote_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + xml_calls <- source_expression$xml_find_function_calls(NULL) - call_arg_expr <- xml_find_all(xml, call_arg_xpath) + call_arg_expr <- xml_find_all(xml_calls, call_arg_xpath) invalid_call_quoting <- is_valid_r_name(get_r_string(call_arg_expr)) @@ -114,7 +108,7 @@ keyword_quote_linter <- function() { invalid_assignment_quoting <- is_valid_r_name(get_r_string(assignment_expr)) # NB: XPath is such that there is exactly 1 node per match, making xml_children() ideal. # xml_child() gets it wrong for 0 (an error) and >1 match. - assignment_to_string <- xml_name(xml2::xml_children(assignment_expr)) == "STR_CONST" + assignment_to_string <- xml_name(xml_children(assignment_expr)) == "STR_CONST" string_assignment_lints <- xml_nodes_to_lints( assignment_expr[assignment_to_string & !invalid_assignment_quoting], diff --git a/R/length_levels_linter.R b/R/length_levels_linter.R index f4c2165ba..5dd26207c 100644 --- a/R/length_levels_linter.R +++ b/R/length_levels_linter.R @@ -18,10 +18,10 @@ #' @evalRd rd_tags("length_levels_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -length_levels_linter <- make_linter_from_xpath( +length_levels_linter <- make_linter_from_function_xpath( + function_names = "levels", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'levels'] - /parent::expr + parent::expr /parent::expr /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'length']] ", diff --git a/R/length_test_linter.R b/R/length_test_linter.R index 901d04462..ca163ea9a 100644 --- a/R/length_test_linter.R +++ b/R/length_test_linter.R @@ -21,17 +21,15 @@ #' @export length_test_linter <- function() { xpath <- glue::glue(" - //SYMBOL_FUNCTION_CALL[text() = 'length'] - /parent::expr + parent::expr /following-sibling::expr[{ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) }] /parent::expr ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + xml_calls <- source_expression$xml_find_function_calls("length") + bad_expr <- xml_find_all(xml_calls, xpath) - bad_expr <- xml_find_all(xml, xpath) expr_parts <- vapply(lapply(bad_expr, xml_find_all, "expr[2]/*"), xml_text, character(3L)) lint_message <- sprintf( "Checking the length of a logical vector is likely a mistake. Did you mean `length(%s) %s %s`?", diff --git a/R/lengths_linter.R b/R/lengths_linter.R index 69ea9eaa7..1616c4a2d 100644 --- a/R/lengths_linter.R +++ b/R/lengths_linter.R @@ -30,14 +30,8 @@ #' @evalRd rd_tags("lengths_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -lengths_linter <- local({ - loop_funs <- c("sapply", "vapply", "map_int", "map_dbl") - make_linter_from_xpath( - xpath = glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(loop_funs)} ] - /parent::expr - /parent::expr[expr/SYMBOL[text() = 'length']] - "), - lint_message = "Use lengths() to find the length of each element in a list." - ) -}) +lengths_linter <- make_linter_from_function_xpath( + function_names = c("sapply", "vapply", "map_int", "map_dbl"), + xpath = "parent::expr/parent::expr[expr/SYMBOL[text() = 'length']]", + lint_message = "Use lengths() to find the length of each element in a list." +) diff --git a/R/library_call_linter.R b/R/library_call_linter.R index fcec3db23..aa311039c 100644 --- a/R/library_call_linter.R +++ b/R/library_call_linter.R @@ -117,10 +117,7 @@ library_call_linter <- function(allow_preamble = TRUE) { ") bad_indirect_funs <- c("do.call", "lapply", "sapply", "map", "walk") - call_symbol_cond <- glue(" - SYMBOL[{attach_call_cond}] - or STR_CONST[{ xp_text_in_table(dQuote(attach_calls, '\"')) }] - ") + call_symbol_cond <- glue("SYMBOL[{attach_call_cond}] or STR_CONST") char_only_indirect_xpath <- glue(" //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(bad_indirect_funs) }] /parent::expr @@ -131,7 +128,7 @@ library_call_linter <- function(allow_preamble = TRUE) { ") call_symbol_path <- glue("./expr[{call_symbol_cond}]") - attach_expr_cond <- glue("expr[expr[SYMBOL_FUNCTION_CALL[{attach_call_cond}]]]") + attach_expr_cond <- glue("expr[expr/SYMBOL_FUNCTION_CALL[{attach_call_cond}]]") # Use `calls` in the first condition, not in the second, to prevent, e.g., # the first call matching calls[1] but the second matching calls[2]. @@ -150,7 +147,6 @@ library_call_linter <- function(allow_preamble = TRUE) { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) upfront_call_expr <- xml_find_all(xml, upfront_call_xpath) @@ -182,7 +178,22 @@ library_call_linter <- function(allow_preamble = TRUE) { ) char_only_indirect_expr <- xml_find_all(xml, char_only_indirect_xpath) - char_only_indirect_lib_calls <- get_r_string(char_only_indirect_expr, call_symbol_path) + char_only_indirect_lib_calls <- vapply( + char_only_indirect_expr, + function(expr) { + calls <- get_r_string(xml_find_all(expr, call_symbol_path)) + calls <- calls[calls %in% attach_calls] + if (length(calls) == 1L) calls else NA_character_ + }, + character(1L) + ) + + # For STR_CONST entries, the XPath doesn't check the string value -- we use + # get_r_string() here to do that filter more robustly. + is_attach_call <- !is.na(char_only_indirect_lib_calls) + char_only_indirect_expr <- char_only_indirect_expr[is_attach_call] + char_only_indirect_lib_calls <- char_only_indirect_lib_calls[is_attach_call] + char_only_indirect_loop_calls <- xp_call_name(char_only_indirect_expr) char_only_indirect_msg <- sprintf( "Call %s() directly, not vectorized with %s().", diff --git a/R/lint.R b/R/lint.R index e7915d856..4435cb081 100644 --- a/R/lint.R +++ b/R/lint.R @@ -24,19 +24,21 @@ #' @param text Optional argument for supplying a string or lines directly, e.g. if the file is already in memory or #' linting is being done ad hoc. #' -#' @aliases lint_file -# TODO(next release after 3.0.0): remove the alias #' @return An object of class `c("lints", "list")`, each element of which is a `"list"` object. #' -#' @examplesIf requireNamespace("withr", quietly = TRUE) -#' f <- withr::local_tempfile(lines = "a=1", fileext = "R") +#' @examples +#' f <- tempfile() +#' writeLines("a=1", f) #' lint(f) # linting a file #' lint("a = 123\n") # linting inline-code #' lint(text = "a = 123") # linting inline-code +#' unlink(f) #' #' @export lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = TRUE, text = NULL) { - check_dots(...names(), c("exclude", "parse_exclusions")) + # TODO(#2502): Remove this workaround. + dot_names <- if (getRversion() %in% c("4.1.1", "4.1.2")) names(list(...)) else ...names() + check_dots(dot_names, c("exclude", "parse_exclusions")) needs_tempfile <- missing(filename) || re_matches(filename, rex(newline)) inline_data <- !is.null(text) || needs_tempfile @@ -139,7 +141,9 @@ lint_dir <- function(path = ".", ..., pattern = "(?i)[.](r|rmd|qmd|rnw|rhtml|rrst|rtex|rtxt)$", parse_settings = TRUE, show_progress = NULL) { - check_dots(...names(), c("lint", "exclude", "parse_exclusions")) + # TODO(#2502): Remove this workaround. + dot_names <- if (getRversion() %in% c("4.1.1", "4.1.2")) names(list(...)) else ...names() + check_dots(dot_names, c("lint", "exclude", "parse_exclusions")) if (isTRUE(parse_settings)) { read_settings(path) diff --git a/R/lintr-deprecated.R b/R/lintr-deprecated.R index 1dc2b323a..2d20aa904 100644 --- a/R/lintr-deprecated.R +++ b/R/lintr-deprecated.R @@ -125,3 +125,77 @@ no_tab_linter <- function() { ) whitespace_linter() } + +#' Extraction operator linter +#' @rdname lintr-deprecated +#' @export +extraction_operator_linter <- function() { + lintr_deprecated( + what = "extraction_operator_linter", + version = "3.2.0", + type = "Linter", + signal = "warning" + ) + + constant_nodes_in_brackets <- paste0("self::", c("expr", "OP-PLUS", "NUM_CONST", "STR_CONST")) + xpath <- glue(" + //OP-DOLLAR[not(preceding-sibling::expr[1]/SYMBOL[text() = 'self' or text() = '.self'])] + | + //OP-LEFT-BRACKET[ + not(following-sibling::expr[1]/descendant::*[not({xp_or(constant_nodes_in_brackets)})]) and + not(following-sibling::OP-COMMA) + ] + ") + + Linter(linter_level = "expression", function(source_expression) { + xml <- source_expression$xml_parsed_content + + bad_exprs <- xml_find_all(xml, xpath) + msgs <- sprintf("Use `[[` instead of `%s` to extract an element.", xml_text(bad_exprs)) + + xml_nodes_to_lints( + bad_exprs, + source_expression = source_expression, + lint_message = msgs, + type = "warning" + ) + }) +} + +#' Unnecessary nested if linter +#' @rdname lintr-deprecated +#' @export +unnecessary_nested_if_linter <- function() { + lintr_deprecated( + what = "unnecessary_nested_if_linter", + alternative = "unnecessary_nesting_linter", + version = "3.2.0", + type = "Linter", + signal = "warning" + ) + + xpath <- paste0( + "//IF/parent::expr[not(ELSE)]/OP-RIGHT-PAREN/", + c( + "following-sibling::expr[IF and not(ELSE)]", # catch if (cond) if (other_cond) { ... } + "following-sibling::expr[OP-LEFT-BRACE and count(expr) = 1] + /expr[IF and not(ELSE)]" # catch if (cond) { if (other_cond) { ... } } + ), + collapse = " | " + ) + + Linter(linter_level = "expression", function(source_expression) { + xml <- source_expression$xml_parsed_content + + bad_exprs <- xml_find_all(xml, xpath) + xml_nodes_to_lints( + bad_exprs, + source_expression = source_expression, + lint_message = paste( + "Don't use nested `if` statements,", + "where a single `if` with the combined conditional expression will do.", + "For example, instead of `if (x) { if (y) { ... }}`, use `if (x && y) { ... }`." + ) + ) + }) +} diff --git a/R/lintr-package.R b/R/lintr-package.R index 11a07a4fe..898db1445 100644 --- a/R/lintr-package.R +++ b/R/lintr-package.R @@ -15,7 +15,7 @@ #' @importFrom utils capture.output getParseData getTxtProgressBar globalVariables head relist #' setTxtProgressBar tail txtProgressBar #' @importFrom xml2 as_list -#' xml_attr xml_find_all xml_find_chr xml_find_lgl xml_find_num xml_find_first xml_name xml_text +#' xml_attr xml_children xml_find_all xml_find_chr xml_find_lgl xml_find_num xml_find_first xml_name xml_text #' @rawNamespace #' if (getRversion() >= "4.0.0") { #' importFrom(tools, R_user_dir) @@ -24,3 +24,8 @@ #' } ## lintr namespace: end NULL + +# make binding available for mock testing +# ref: https://testthat.r-lib.org/dev/reference/local_mocked_bindings.html#base-functions +unlink <- NULL +quit <- NULL diff --git a/R/list_comparison_linter.R b/R/list_comparison_linter.R index c1676c120..eb48bdb07 100644 --- a/R/list_comparison_linter.R +++ b/R/list_comparison_linter.R @@ -21,8 +21,6 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export list_comparison_linter <- function() { - # TODO(michaelchirico): extend to cases where using simplify=FALSE implies a - # list output, e.g. with sapply, replicate, mapply. list_mapper_alternatives <- c( lapply = "vapply(x, FUN, character(1L))", map = "map_chr(x, FUN)", @@ -33,17 +31,14 @@ list_comparison_linter <- function() { # NB: anchor to the comparison expr so that we can easily include the comparator # in the lint message. xpath <- glue(" - //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(names(list_mapper_alternatives)) }] - /parent::expr + parent::expr /parent::expr /parent::expr[{ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) }] ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(names(list_mapper_alternatives)) + bad_expr <- xml_find_all(xml_calls, xpath) list_mapper <- xp_call_name(bad_expr, depth = 2L) diff --git a/R/literal_coercion_linter.R b/R/literal_coercion_linter.R index 5cc230376..63eb245c3 100644 --- a/R/literal_coercion_linter.R +++ b/R/literal_coercion_linter.R @@ -46,11 +46,11 @@ #' @export literal_coercion_linter <- function() { rlang_coercers <- c("lgl", "int", "dbl", "chr") - coercers <- xp_text_in_table(c( + coercers <- c( # base coercers paste0("as.", c("logical", "integer", "numeric", "double", "character")), rlang_coercers - )) + ) # notes for clarification: # - as.integer(1e6) is arguably easier to read than 1000000L @@ -65,8 +65,7 @@ literal_coercion_linter <- function() { ) " xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {coercers} ] - /parent::expr + parent::expr /parent::expr[ count(expr) = 2 and expr[2][ {not_extraction_or_scientific} ] @@ -74,10 +73,8 @@ literal_coercion_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(coercers) + bad_expr <- xml_find_all(xml_calls, xpath) coercer <- xp_call_name(bad_expr) # tiptoe around the fact that we don't require {rlang} @@ -101,9 +98,7 @@ literal_coercion_linter <- function() { coercion_str[needs_prefix] <- paste0("rlang::", coercion_str[needs_prefix]) } # the linter logic & rlang requirement should ensure that it's safe to run eval() here - # TODO(michaelchirico): this recommends '1' to replace as.numeric(1), where our - # own implicit_integer_linter(), if active, would require this to be 1.0. Should - # we recommend this instead, or offer it as an alternative? + # TODO(#2473): Avoid a recommendation like '1' that clashes with implicit_integer_linter(). literal_equivalent_str <- vapply(str2expression(coercion_str), function(expr) deparse1(eval(expr)), character(1L)) lint_message <- sprintf( "Use %s instead of %s, i.e., use literals directly where possible, instead of coercion.", diff --git a/R/make_linter_from_xpath.R b/R/make_linter_from_xpath.R index ded1fd921..e707247d9 100644 --- a/R/make_linter_from_xpath.R +++ b/R/make_linter_from_xpath.R @@ -3,6 +3,8 @@ #' @inheritParams xml_nodes_to_lints #' @inheritParams is_lint_level #' @param xpath Character string, an XPath identifying R code to lint. +#' For `make_linter_from_function_xpath()`, the XPath is relative to the `SYMBOL_FUNCTION_CALL` nodes of the +#' selected functions. #' See [xmlparsedata::xml_parse_data()] and [get_source_expressions()]. #' #' @examples @@ -25,7 +27,7 @@ make_linter_from_xpath <- function(xpath, function() { Linter(linter_level = level, function(source_expression) { xml <- source_expression[[xml_key]] - if (is.null(xml)) return(list()) + expr <- xml_find_all(xml, xpath) @@ -38,3 +40,36 @@ make_linter_from_xpath <- function(xpath, }) } } + +#' @rdname make_linter_from_xpath +#' @param function_names Character vector, names of functions whose calls to examine.. +#' @export +# nolint next: object_length. +make_linter_from_function_xpath <- function(function_names, + xpath, + lint_message, + type = c("warning", "style", "error"), + level = c("expression", "file")) { + type <- match.arg(type) + level <- match.arg(level) + + stopifnot( + "function_names should be a character vector" = is.character(function_names) && length(function_names) > 0L, + "xpath should be a character string" = is.character(xpath) && length(xpath) == 1L && !is.na(xpath) + ) + + function() { + Linter(linter_level = level, function(source_expression) { + call_xml <- source_expression$xml_find_function_calls(function_names) + + expr <- xml_find_all(call_xml, xpath) + + xml_nodes_to_lints( + expr, + source_expression = source_expression, + lint_message = lint_message, + type = type + ) + }) + } +} diff --git a/R/matrix_apply_linter.R b/R/matrix_apply_linter.R index 7b3bb29e9..fc12ab368 100644 --- a/R/matrix_apply_linter.R +++ b/R/matrix_apply_linter.R @@ -36,8 +36,7 @@ matrix_apply_linter <- function() { # # Currently supported values for MARGIN: scalar numeric and vector of contiguous values created by : (OP-COLON) sums_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'apply'] - /parent::expr + parent::expr /following-sibling::expr[ NUM_CONST or OP-COLON/preceding-sibling::expr[NUM_CONST]/following-sibling::expr[NUM_CONST] and (position() = 2) @@ -52,8 +51,7 @@ matrix_apply_linter <- function() { # Since mean() is a generic, we make sure that we only lint cases with arguments # supported by colMeans() and rowMeans(), i.e., na.rm means_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'apply'] - /parent::expr + parent::expr /following-sibling::expr[ NUM_CONST or OP-COLON/preceding-sibling::expr[NUM_CONST]/following-sibling::expr[NUM_CONST] and (position() = 2) @@ -77,10 +75,8 @@ matrix_apply_linter <- function() { fun_xpath <- "expr[position() = 4]" Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("apply") + bad_expr <- xml_find_all(xml_calls, xpath) variable <- xml_text(xml_find_all(bad_expr, variable_xpath)) diff --git a/R/methods.R b/R/methods.R index 123d1e312..4ff71c0a1 100644 --- a/R/methods.R +++ b/R/methods.R @@ -95,18 +95,6 @@ print.lints <- function(x, ...) { } else if (in_github_actions()) { github_actions_log_lints(x, project_dir = github_annotation_project_dir) } else { - if (in_ci() && settings$comment_bot) { - info <- ci_build_info() - - lint_output <- trim_output( - paste0( - collapse = "\n", - capture.output(invisible(lapply(x, markdown, info, ...))) - ) - ) - - github_comment(lint_output, info, ...) - } lapply(x, print, ...) } diff --git a/R/missing_argument_linter.R b/R/missing_argument_linter.R index d549169dd..79b62841b 100644 --- a/R/missing_argument_linter.R +++ b/R/missing_argument_linter.R @@ -37,23 +37,34 @@ missing_argument_linter <- function(except = c("alist", "quote", "switch"), allo "self::EQ_SUB[following-sibling::*[not(self::COMMENT)][1][self::OP-RIGHT-PAREN or self::OP-COMMA]]" ) if (!allow_trailing) { - conds <- c(conds, "self::OP-COMMA[following-sibling::*[not(self::COMMENT)][1][self::OP-RIGHT-PAREN]]") + conds <- c(conds, + "self::OP-RIGHT-PAREN[preceding-sibling::*[not(self::COMMENT)][1][self::OP-LEFT-PAREN or self::OP-COMMA]]" + ) } - xpath <- glue("//SYMBOL_FUNCTION_CALL/parent::expr/parent::expr/*[{xp_or(conds)}]") - to_function_xpath <- "string(./preceding-sibling::expr[last()]/SYMBOL_FUNCTION_CALL)" + # require >3 children to exclude foo(), which is + xpath <- glue(" + parent::expr + /parent::expr[count(*) > 3] + /*[{xp_or(conds)}] + ") Linter(linter_level = "file", function(source_expression) { - xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) + xml_targets <- source_expression$xml_find_function_calls(NULL, keep_names = TRUE) + xml_targets <- xml_targets[!names(xml_targets) %in% except] + + missing_args <- xml_find_all(xml_targets, xpath) - missing_args <- xml_find_all(xml, xpath) - function_call_name <- get_r_string(xml_find_chr(missing_args, to_function_xpath)) + named_idx <- xml_name(missing_args) == "EQ_SUB" + arg_id <- character(length(missing_args)) + arg_id[named_idx] <- sQuote(xml_find_chr(missing_args[named_idx], "string(preceding-sibling::SYMBOL_SUB[1])"), "'") + # TODO(#2452): use xml_find_int() instead + arg_id[!named_idx] <- xml_find_num(missing_args[!named_idx], "count(preceding-sibling::OP-COMMA)") + 1.0 xml_nodes_to_lints( - missing_args[!function_call_name %in% except], + missing_args, source_expression = source_expression, - lint_message = "Missing argument in function call." + lint_message = sprintf("Missing argument %s in function call.", arg_id) ) }) } diff --git a/R/missing_package_linter.R b/R/missing_package_linter.R index c056f1333..96eb8ba54 100644 --- a/R/missing_package_linter.R +++ b/R/missing_package_linter.R @@ -20,8 +20,7 @@ #' @export missing_package_linter <- function() { library_require_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] - /parent::expr + parent::expr /parent::expr[ expr[2][STR_CONST] or ( @@ -35,18 +34,18 @@ missing_package_linter <- function() { ] " load_require_namespace_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'loadNamespace' or text() = 'requireNamespace'] - /parent::expr + parent::expr /following-sibling::expr[1][STR_CONST] /parent::expr " - call_xpath <- paste(library_require_xpath, "|", load_require_namespace_xpath) Linter(linter_level = "file", function(source_expression) { - xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - - pkg_calls <- xml_find_all(xml, call_xpath) + library_require_calls <- source_expression$xml_find_function_calls(c("library", "require")) + load_require_namespace_calls <- source_expression$xml_find_function_calls(c("loadNamespace", "requireNamespace")) + pkg_calls <- combine_nodesets( + xml_find_all(library_require_calls, library_require_xpath), + xml_find_all(load_require_namespace_calls, load_require_namespace_xpath) + ) pkg_names <- get_r_string(xml_find_all( pkg_calls, "OP-LEFT-PAREN[1]/following-sibling::expr[1][SYMBOL | STR_CONST]" diff --git a/R/namespace_linter.R b/R/namespace_linter.R index e0bc85eb5..d6579a86a 100644 --- a/R/namespace_linter.R +++ b/R/namespace_linter.R @@ -41,7 +41,6 @@ namespace_linter <- function(check_exports = TRUE, check_nonexports = TRUE) { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) ns_nodes <- xml_find_all(xml, "//NS_GET | //NS_GET_INT") @@ -157,7 +156,7 @@ build_ns_get_int_lints <- function(packages, symbols, symbol_nodes, namespaces, symbol_nodes[exported], source_expression = source_expression, lint_message = - sprintf("'%1$s' is exported from {%2$s}. Use %2$s::%1$s instead.", symbols[exported], packages[exported]), + sprintf("Don't use `:::` to access %s, which is exported from %s.", symbols[exported], packages[exported]), type = "warning" ) diff --git a/R/nested_ifelse_linter.R b/R/nested_ifelse_linter.R index 8657333ff..6441896c5 100644 --- a/R/nested_ifelse_linter.R +++ b/R/nested_ifelse_linter.R @@ -81,16 +81,13 @@ nested_ifelse_linter <- function() { # NB: land on the nested (inner) call, not the outer call, and throw a lint with the inner call's name xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)}] - /parent::expr + parent::expr /following-sibling::expr[expr[1][SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ]]] ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(ifelse_funs) + bad_expr <- xml_find_all(xml_calls, xpath) matched_call <- xp_call_name(bad_expr) lint_message <- paste( diff --git a/R/nested_pipe_linter.R b/R/nested_pipe_linter.R index a7a8c323b..fd595b233 100644 --- a/R/nested_pipe_linter.R +++ b/R/nested_pipe_linter.R @@ -69,7 +69,6 @@ nested_pipe_linter <- function( Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) diff --git a/R/nrow_subset_linter.R b/R/nrow_subset_linter.R index eb731e579..57ad645e1 100644 --- a/R/nrow_subset_linter.R +++ b/R/nrow_subset_linter.R @@ -14,6 +14,16 @@ #' linters = nrow_subset_linter() #' ) #' +#' lint( +#' text = "nrow(filter(x, is_treatment))", +#' linters = nrow_subset_linter() +#' ) +#' +#' lint( +#' text = "x %>% filter(x, is_treatment) %>% nrow()", +#' linters = nrow_subset_linter() +#' ) +#' #' # okay #' lint( #' text = "with(x, sum(is_treatment, na.rm = TRUE))", @@ -22,19 +32,25 @@ #' #' @evalRd rd_tags("nrow_subset_linter") #' @seealso [linters] for a complete list of linters available in lintr. +#' @include shared_constants.R #' @export -nrow_subset_linter <- make_linter_from_xpath( - xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'subset'] - /parent::expr +nrow_subset_linter <- make_linter_from_function_xpath( + function_names = c("subset", "filter"), + xpath = glue(" + parent::expr /parent::expr - /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'nrow']] - ", + /parent::expr[ + expr/SYMBOL_FUNCTION_CALL[text() = 'nrow'] + or (self::expr | parent::expr)[ + (PIPE or SPECIAL[{ xp_text_in_table(setdiff(magrittr_pipes, c('%$%', '%<>%'))) }]) + and expr/expr/SYMBOL_FUNCTION_CALL[text() = 'nrow'] + ] + ] + "), lint_message = paste( "Use arithmetic to count the number of rows satisfying a condition,", "rather than fully subsetting the data.frame and counting the resulting rows.", - "For example, replace nrow(subset(x, is_treatment))", - "with sum(x$is_treatment). NB: use na.rm = TRUE if `is_treatment` has", - "missing values." + "For example, replace nrow(subset(x, is_treatment)) with sum(x$is_treatment).", + "NB: use na.rm = TRUE if `is_treatment` has missing values." ) ) diff --git a/R/nzchar_linter.R b/R/nzchar_linter.R index b9e36b89f..e9f0dadb5 100644 --- a/R/nzchar_linter.R +++ b/R/nzchar_linter.R @@ -6,7 +6,9 @@ #' #' One crucial difference is in the default handling of `NA_character_`, i.e., #' missing strings. `nzchar(NA_character_)` is `TRUE`, while `NA_character_ == ""` -#' and `nchar(NA_character_) == 0` are both `NA`. +#' and `nchar(NA_character_) == 0` are both `NA`. Therefore, for strict +#' compatibility, use `nzchar(x, keepNA = TRUE)`. If the input is known to be +#' complete (no missing entries), this argument can be dropped for conciseness. #' #' @examples #' # will produce lints @@ -22,14 +24,12 @@ #' #' # okay #' lint( -#' text = "x[nchar(x) > 1]", +#' text = "x[!nzchar(x, keepNA = TRUE)]", #' linters = nzchar_linter() #' ) #' -#' # nzchar()'s primary benefit is for vector input; -#' # for guaranteed-scalar cases like if() conditions, comparing to "" is OK. #' lint( -#' text = "if (x == '') y", +#' text = "x[nzchar(x, keepNA = TRUE)]", #' linters = nzchar_linter() #' ) #' @@ -55,7 +55,7 @@ nzchar_linter <- function() { ]) or ancestor-or-self::expr[ ( - preceding-sibling::expr[SYMBOL_FUNCTION_CALL] + preceding-sibling::expr/SYMBOL_FUNCTION_CALL or preceding-sibling::OP-LEFT-BRACKET ) and not( descendant-or-self::expr[IF or WHILE] @@ -65,58 +65,91 @@ nzchar_linter <- function() { ] ") + comparison_msg_map <- c( + GT = 'Use nzchar(x) instead of x > "". ', + NE = 'Use nzchar(x) instead of x != "". ', + LE = 'Use !nzchar(x) instead of x <= "". ', + EQ = 'Use !nzchar(x) instead of x == "". ', + GE = 'x >= "" is always true, maybe you want nzchar(x)? ', + LT = 'x < "" is always false, maybe you want !nzchar(x)? ' + ) + # nchar(., type="width") not strictly compatible with nzchar # unsure allowNA compatible, so allow it just in case (see TODO in tests) nchar_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'nchar'] - /parent::expr + parent::expr /parent::expr /parent::expr[ ({ xp_or(comparator_nodes) }) - and not(expr[SYMBOL_SUB[ + and not(expr/SYMBOL_SUB[ ( text() = 'type' - and following-sibling::expr[1][STR_CONST[contains(text(), 'width')]] + and following-sibling::expr[1]/STR_CONST[contains(text(), 'width')] ) or ( text() = 'allowNA' - and following-sibling::expr[1][NUM_CONST[text() = 'TRUE']] + and following-sibling::expr[1]/NUM_CONST[text() = 'TRUE'] ) - ]]) - and expr[NUM_CONST[text() = '0' or text() = '0L' or text() = '0.0']] + ]) + and expr/NUM_CONST[text() = '0' or text() = '0L' or text() = '0.0'] ] ") + nchar_msg_map <- c( + GT = "Use nzchar(x) instead of nchar(x) > 0. ", + NE = "Use nzchar(x) instead of nchar(x) != 0. ", + LE = "Use !nzchar(x) instead of nchar(x) <= 0. ", + EQ = "Use !nzchar(x) instead of nchar(x) == 0. ", + GE = "nchar(x) >= 0 is always true, maybe you want nzchar(x)? ", + LT = "nchar(x) < 0 is always false, maybe you want !nzchar(x)? " + ) + keepna_note <- paste( "Whenever missing data is possible,", "please take care to use nzchar(., keepNA = TRUE);", "nzchar(NA) is TRUE by default." ) + # For ordered operators like '>', we need to give the message for + # its "opposite" (not inverse) if the bad usage is on the RHS, + # e.g. 0 < nchar(x) has to be treated as nchar(x) > 0. + op_for_msg <- function(expr, const) { + op <- xml_name(xml_find_first(expr, "*[2]")) + maybe_needs_flip <- !is.na(xml_find_first(expr, sprintf("*[1][%s]", const))) + + ordered_ops <- c("GT", "GE", "LE", "LT") + ordered_idx <- match(op, ordered_ops) + + needs_flip <- maybe_needs_flip & !is.na(ordered_idx) + # un-benchmarked, but should be faster (though less readable) as + # > ordered_ops[5L - ordered_idx[needs_flip]] + op[needs_flip] <- rev(ordered_ops)[ordered_idx[needs_flip]] + op + } + Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) comparison_expr <- xml_find_all(xml, comparison_xpath) + comparison_op <- op_for_msg(comparison_expr, const = "STR_CONST") comparison_lints <- xml_nodes_to_lints( comparison_expr, source_expression = source_expression, - lint_message = paste( - 'Instead of comparing strings to "", use nzchar().', - "Note that if x is a factor, you'll have use ", - 'as.character() to replicate an implicit conversion that happens in x == "".', + lint_message = paste0( + comparison_msg_map[comparison_op], + "Note that unlike nzchar(), ", comparison_op, " coerces to character, ", + "so you'll have to use as.character() if x is a factor. ", keepna_note ), type = "warning" ) - nchar_expr <- xml_find_all(xml, nchar_xpath) + xml_calls <- source_expression$xml_find_function_calls("nchar") + nchar_expr <- xml_find_all(xml_calls, nchar_xpath) + nchar_op <- op_for_msg(nchar_expr, const = "NUM_CONST") nchar_lints <- xml_nodes_to_lints( nchar_expr, source_expression = source_expression, - lint_message = paste( - "Instead of comparing nchar(x) to 0, use nzchar().", - keepna_note - ), + lint_message = paste0(nchar_msg_map[nchar_op], keepna_note), type = "warning" ) diff --git a/R/object_length_linter.R b/R/object_length_linter.R index ced9a13e9..0109856bb 100644 --- a/R/object_length_linter.R +++ b/R/object_length_linter.R @@ -39,7 +39,6 @@ object_length_linter <- function(length = 30L) { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) assignments <- xml_find_all(xml, object_name_xpath) diff --git a/R/object_name_linter.R b/R/object_name_linter.R index f8e5e6422..bb506692d 100644 --- a/R/object_name_linter.R +++ b/R/object_name_linter.R @@ -112,7 +112,6 @@ object_name_linter <- function(styles = c("snake_case", "symbols"), regexes = ch Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) assignments <- xml_find_all(xml, object_name_xpath) @@ -175,25 +174,6 @@ check_style <- function(nms, style, generics = character()) { conforming } -# see ?".onLoad", ?Startup, and ?quit. Remove leading dot to match behavior of strip_names(). -# All of .onLoad, .onAttach, and .onUnload are used in base packages, -# and should be caught in is_base_function; they're included here for completeness / stability -# (they don't strictly _have_ to be defined in base, so could in principle be removed). -# .Last.sys and .First.sys are part of base itself, so aren't included here. -special_funs <- c( - ".onLoad", - ".onAttach", - ".onUnload", - ".onDetach", - ".Last.lib", - ".First", - ".Last" -) - -is_special_function <- function(x) { - x %in% special_funs -} - loweralnum <- rex(one_of(lower, digit)) upperalnum <- rex(one_of(upper, digit)) diff --git a/R/object_overwrite_linter.R b/R/object_overwrite_linter.R index 3f43fba69..6c2eaa27d 100644 --- a/R/object_overwrite_linter.R +++ b/R/object_overwrite_linter.R @@ -95,7 +95,6 @@ object_overwrite_linter <- function( Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) assigned_exprs <- xml_find_all(xml, xpath_assignments) assigned_symbols <- get_r_string(assigned_exprs, "SYMBOL|STR_CONST") diff --git a/R/object_usage_linter.R b/R/object_usage_linter.R index dcf41e449..21cb1151e 100644 --- a/R/object_usage_linter.R +++ b/R/object_usage_linter.R @@ -58,7 +58,6 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) { declared_globals <- try_silently(globalVariables(package = pkg_name %||% globalenv())) xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) # run the following at run-time, not "compile" time to allow package structure to change env <- make_check_env(pkg_name, xml) @@ -88,8 +87,6 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) { skip_with = skip_with ) - # TODO handle assignment functions properly - # e.g. `not_existing<-`(a, b) res$name <- re_substitutes(res$name, rex("<-"), "") lintable_symbols <- xml_find_all(fun_assignment, xpath_culprit_symbol) @@ -212,7 +209,7 @@ parse_check_usage <- function(expression, # nocov start is_missing <- is.na(res$message) if (any(is_missing)) { - # TODO (AshesITR): Remove this in the future, if no bugs arise from this safeguard + # TODO(#2474): Remove this. warning( "Possible bug in lintr: Couldn't parse usage message ", sQuote(vals[is_missing][[1L]]), ". ", "Ignoring ", sum(is_missing), " usage warnings. Please report an issue at https://github.com/r-lib/lintr/issues.", diff --git a/R/one_call_pipe_linter.R b/R/one_call_pipe_linter.R index f780ce02b..b11e3a7b7 100644 --- a/R/one_call_pipe_linter.R +++ b/R/one_call_pipe_linter.R @@ -67,7 +67,6 @@ one_call_pipe_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) pipe <- xml_find_chr(bad_expr, "string(SPECIAL | PIPE)") @@ -75,7 +74,7 @@ one_call_pipe_linter <- function() { xml_nodes_to_lints( bad_expr, source_expression = source_expression, - lint_message = paste0("Expressions with only a single call shouldn't use pipe ", pipe, "."), + lint_message = paste0("Avoid pipe ", pipe, " for expressions with only a single call."), type = "warning" ) }) diff --git a/R/outer_negation_linter.R b/R/outer_negation_linter.R index a6338c5a1..f9f5a6715 100644 --- a/R/outer_negation_linter.R +++ b/R/outer_negation_linter.R @@ -39,8 +39,7 @@ outer_negation_linter <- function() { # NB: requirement that count(expr)>1 is to prevent any() from linting # e.g. in magrittr pipelines. xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'any' or text() = 'all'] - /parent::expr[following-sibling::expr] + parent::expr[following-sibling::expr] /parent::expr[ not(expr[ position() > 1 @@ -51,10 +50,8 @@ outer_negation_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(c("any", "all")) + bad_expr <- xml_find_all(xml_calls, xpath) matched_call <- xp_call_name(bad_expr) inverse_call <- ifelse(matched_call == "any", "all", "any") diff --git a/R/package_hooks_linter.R b/R/package_hooks_linter.R index 1234109c0..112d84210 100644 --- a/R/package_hooks_linter.R +++ b/R/package_hooks_linter.R @@ -128,7 +128,6 @@ package_hooks_linter <- function() { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) any_hook <- xml_find_first(xml, any_hook_xpath) if (is.na(any_hook)) { diff --git a/R/paren_body_linter.R b/R/paren_body_linter.R index eb44a8087..b8ec09e40 100644 --- a/R/paren_body_linter.R +++ b/R/paren_body_linter.R @@ -47,6 +47,6 @@ paren_body_linter <- make_linter_from_xpath( ] /following-sibling::expr ", - lint_message = "There should be a space between a right parenthesis and a body expression.", + lint_message = "Put a space between a right parenthesis and a body expression.", type = "style" ) diff --git a/R/paste_linter.R b/R/paste_linter.R index 802c078ef..cd054a068 100644 --- a/R/paste_linter.R +++ b/R/paste_linter.R @@ -1,5 +1,7 @@ #' Raise lints for several common poor usages of `paste()` #' +#' @description +#' #' The following issues are linted by default by this linter #' (see arguments for which can be de-activated optionally): #' @@ -106,15 +108,13 @@ paste_linter <- function(allow_empty_sep = FALSE, check_file_paths <- allow_file_path %in% c("double_slash", "never") paste_sep_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste'] - /parent::expr + parent::expr /following-sibling::SYMBOL_SUB[text() = 'sep' and following-sibling::expr[1][STR_CONST]] /parent::expr " to_string_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste' or text() = 'paste0'] - /parent::expr + parent::expr /parent::expr[ count(expr) = 3 and SYMBOL_SUB[text() = 'collapse']/following-sibling::expr[1][STR_CONST] @@ -122,27 +122,23 @@ paste_linter <- function(allow_empty_sep = FALSE, " paste0_sep_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste0'] - /parent::expr + parent::expr /following-sibling::SYMBOL_SUB[text() = 'sep'] /parent::expr " paste_strrep_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste' or text() = 'paste0'] - /parent::expr[ - count(following-sibling::expr) = 2 - and following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'rep']] and expr[2][STR_CONST]] - and following-sibling::SYMBOL_SUB[text() = 'collapse'] - ] - /parent::expr + parent::expr[ + count(following-sibling::expr) = 2 + and following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'rep']] and expr[2][STR_CONST]] + and following-sibling::SYMBOL_SUB[text() = 'collapse'] + ]/parent::expr " # Type II: paste0(x, "/", y, "/", z) # NB: some conditions require evaluating the R string, only a few can be done in pure XPath. See below. paste0_file_path_xpath <- xp_strip_comments(" - //SYMBOL_FUNCTION_CALL[text() = 'paste0'] - /parent::expr + parent::expr /parent::expr[ (: exclude paste0(x) :) count(expr) > 2 @@ -162,14 +158,16 @@ paste_linter <- function(allow_empty_sep = FALSE, 'Note that paste() converts empty inputs to "", whereas file.path() leaves it empty.' Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + paste_calls <- source_expression$xml_find_function_calls("paste") + paste0_calls <- source_expression$xml_find_function_calls("paste0") + both_calls <- combine_nodesets(paste_calls, paste0_calls) + optional_lints <- list() # Both of these look for paste(..., sep = "..."), differing in which 'sep' is linted, # so run the expensive XPath search/R parse only once if (!allow_empty_sep || check_file_paths) { - paste_sep_expr <- xml_find_all(xml, paste_sep_xpath) + paste_sep_expr <- xml_find_all(paste_calls, paste_sep_xpath) paste_sep_value <- get_r_string(paste_sep_expr, xpath = "./SYMBOL_SUB[text() = 'sep']/following-sibling::expr[1]") } @@ -184,7 +182,7 @@ paste_linter <- function(allow_empty_sep = FALSE, if (!allow_to_string) { # 3 expr: the function call, the argument, and collapse= - to_string_expr <- xml_find_all(xml, to_string_xpath) + to_string_expr <- xml_find_all(both_calls, to_string_xpath) collapse_value <- get_r_string( to_string_expr, xpath = "./SYMBOL_SUB[text() = 'collapse']/following-sibling::expr[1]" @@ -202,7 +200,7 @@ paste_linter <- function(allow_empty_sep = FALSE, )) } - paste0_sep_expr <- xml_find_all(xml, paste0_sep_xpath) + paste0_sep_expr <- xml_find_all(paste0_calls, paste0_sep_xpath) paste0_sep_lints <- xml_nodes_to_lints( paste0_sep_expr, source_expression = source_expression, @@ -210,7 +208,7 @@ paste_linter <- function(allow_empty_sep = FALSE, type = "warning" ) - paste_strrep_expr <- xml_find_all(xml, paste_strrep_xpath) + paste_strrep_expr <- xml_find_all(both_calls, paste_strrep_xpath) collapse_arg <- get_r_string(paste_strrep_expr, "SYMBOL_SUB/following-sibling::expr[1]/STR_CONST") paste_strrep_expr <- paste_strrep_expr[!nzchar(collapse_arg)] paste_call <- xp_call_name(paste_strrep_expr) @@ -236,7 +234,7 @@ paste_linter <- function(allow_empty_sep = FALSE, type = "warning" )) - paste0_file_path_expr <- xml_find_all(xml, paste0_file_path_xpath) + paste0_file_path_expr <- xml_find_all(paste0_calls, paste0_file_path_xpath) is_file_path <- !vapply(paste0_file_path_expr, check_is_not_file_path, logical(1L), allow_file_path = allow_file_path) optional_lints <- c(optional_lints, xml_nodes_to_lints( diff --git a/R/pipe_call_linter.R b/R/pipe_call_linter.R index 5f2723999..e0b55279e 100644 --- a/R/pipe_call_linter.R +++ b/R/pipe_call_linter.R @@ -28,7 +28,6 @@ pipe_call_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) pipe <- xml_text(xml_find_first(bad_expr, "preceding-sibling::SPECIAL[1]")) diff --git a/R/pipe_consistency_linter.R b/R/pipe_consistency_linter.R index d463f584a..323e0ef78 100644 --- a/R/pipe_consistency_linter.R +++ b/R/pipe_consistency_linter.R @@ -40,7 +40,6 @@ pipe_consistency_linter <- function(pipe = c("auto", "%>%", "|>")) { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) match_magrittr <- xml_find_all(xml, xpath_magrittr) match_native <- xml_find_all(xml, xpath_native) @@ -53,8 +52,7 @@ pipe_consistency_linter <- function(pipe = c("auto", "%>%", "|>")) { xml = c(match_magrittr, match_native), source_expression = source_expression, lint_message = glue( - "Found {n_magrittr} instances of %>% and {n_native} instances of |>. ", - "Stick to one pipe operator." + "Stick to one pipe operator; found {n_magrittr} instances of %>% and {n_native} instances of |>." ), type = "style" ) diff --git a/R/pipe_continuation_linter.R b/R/pipe_continuation_linter.R index 0c03cf46c..10d55b548 100644 --- a/R/pipe_continuation_linter.R +++ b/R/pipe_continuation_linter.R @@ -69,7 +69,6 @@ pipe_continuation_linter <- function() { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) pipe_exprs <- xml_find_all(xml, xpath) pipe_text <- xml_text(pipe_exprs) @@ -78,7 +77,7 @@ pipe_continuation_linter <- function() { pipe_exprs, source_expression = source_expression, lint_message = sprintf( - "`%s` should always have a space before it and a new line after it, unless the full pipeline fits on one line.", + "Put a space before `%s` and a new line after it, unless the full pipeline fits on one line.", pipe_text ), type = "style" diff --git a/R/pipe_return_linter.R b/R/pipe_return_linter.R index fd73da8ae..57b5bcafe 100644 --- a/R/pipe_return_linter.R +++ b/R/pipe_return_linter.R @@ -32,8 +32,7 @@ pipe_return_linter <- make_linter_from_xpath( /following-sibling::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'return']] ", lint_message = paste( - "Using return() as the final step of a magrittr pipeline", - "is an anti-pattern. Instead, assign the output of the pipeline to", - "a well-named object and return that." + "Avoid return() as the final step of a magrittr pipeline. ", + "Instead, assign the output of the pipeline to a well-named object and return that." ) ) diff --git a/R/print_linter.R b/R/print_linter.R index 72b90d66a..438ecc0f5 100644 --- a/R/print_linter.R +++ b/R/print_linter.R @@ -29,10 +29,10 @@ #' @evalRd rd_tags("print_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -print_linter <- make_linter_from_xpath( +print_linter <- make_linter_from_function_xpath( + function_names = "print", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'print'] - /parent::expr + parent::expr /parent::expr[expr[2][ STR_CONST or expr/SYMBOL_FUNCTION_CALL[ diff --git a/R/quotes_linter.R b/R/quotes_linter.R index e93ca7a7b..10099463e 100644 --- a/R/quotes_linter.R +++ b/R/quotes_linter.R @@ -62,7 +62,7 @@ quotes_linter <- function(delimiter = c('"', "'")) { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + string_exprs <- xml_find_all(xml, "//STR_CONST") is_bad <- re_matches(xml_text(string_exprs), quote_regex) diff --git a/R/redundant_equals_linter.R b/R/redundant_equals_linter.R index d8087400e..48d524c5b 100644 --- a/R/redundant_equals_linter.R +++ b/R/redundant_equals_linter.R @@ -45,7 +45,6 @@ redundant_equals_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) op <- xml_text(xml_find_first(bad_expr, "*[2]")) diff --git a/R/redundant_ifelse_linter.R b/R/redundant_ifelse_linter.R index 81acb5c33..4c01a3d32 100644 --- a/R/redundant_ifelse_linter.R +++ b/R/redundant_ifelse_linter.R @@ -45,8 +45,7 @@ #' @export redundant_ifelse_linter <- function(allow10 = FALSE) { tf_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /parent::expr[ expr[position() <= 4 and NUM_CONST[text() = 'TRUE']] and expr[position() <= 4 and NUM_CONST[text() = 'FALSE']] @@ -58,8 +57,7 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { ") num_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /parent::expr[ expr[position() <= 4 and NUM_CONST[text() = '1' or text() = '1L']] and expr[position() <= 4 and NUM_CONST[text() = '0' or text() = '0L']] @@ -71,11 +69,11 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + xml_targets <- source_expression$xml_find_function_calls(ifelse_funs) + lints <- list() - tf_expr <- xml_find_all(xml, tf_xpath) + tf_expr <- xml_find_all(xml_targets, tf_xpath) matched_call <- xp_call_name(tf_expr) # [1] call; [2] logical condition first_arg <- xml_find_chr(tf_expr, "string(expr[3]/NUM_CONST)") @@ -87,7 +85,7 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { lints <- c(lints, xml_nodes_to_lints(tf_expr, source_expression, tf_message, type = "warning")) if (!allow10) { - num_expr <- xml_find_all(xml, num_xpath) + num_expr <- xml_find_all(xml_targets, num_xpath) matched_call <- xp_call_name(num_expr) # [1] call; [2] logical condition first_arg <- xml_find_chr(num_expr, "string(expr[3]/NUM_CONST)") diff --git a/R/regex_subset_linter.R b/R/regex_subset_linter.R index 619c53764..33a9fd8d6 100644 --- a/R/regex_subset_linter.R +++ b/R/regex_subset_linter.R @@ -54,8 +54,7 @@ regex_subset_linter <- function() { # is basically what we need, i.e., whatever expression comes in # [grepl(pattern, )] matches exactly, e.g. names(x)[grepl(ptn, names(x))]. xpath_fmt <- " - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(calls)} ] - /parent::expr + parent::expr /parent::expr[ parent::expr[ OP-LEFT-BRACKET @@ -64,14 +63,12 @@ regex_subset_linter <- function() { and expr[position() = {arg_pos} ] = parent::expr/expr[1] ] " - grep_xpath <- glue(xpath_fmt, calls = c("grepl", "grep"), arg_pos = 3L) - stringr_xpath <- glue(xpath_fmt, calls = c("str_detect", "str_which"), arg_pos = 2L) + grep_xpath <- glue(xpath_fmt, arg_pos = 3L) + stringr_xpath <- glue(xpath_fmt, arg_pos = 2L) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - grep_expr <- xml_find_all(xml, grep_xpath) + grep_calls <- source_expression$xml_find_function_calls(c("grepl", "grep")) + grep_expr <- xml_find_all(grep_calls, grep_xpath) grep_lints <- xml_nodes_to_lints( grep_expr, @@ -81,7 +78,8 @@ regex_subset_linter <- function() { type = "warning" ) - stringr_expr <- xml_find_all(xml, stringr_xpath) + stringr_calls <- source_expression$xml_find_function_calls(c("str_detect", "str_which")) + stringr_expr <- xml_find_all(stringr_calls, stringr_xpath) stringr_lints <- xml_nodes_to_lints( stringr_expr, diff --git a/R/rep_len_linter.R b/R/rep_len_linter.R index f3eae2e5d..4e0dd583a 100644 --- a/R/rep_len_linter.R +++ b/R/rep_len_linter.R @@ -24,11 +24,11 @@ #' @evalRd rd_tags("rep_len_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -rep_len_linter <- make_linter_from_xpath( +rep_len_linter <- make_linter_from_function_xpath( + function_names = "rep", # count(expr) is for cases using positional matching; see ?rep. xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'rep'] - /parent::expr + parent::expr /parent::expr[ ( SYMBOL_SUB[text() = 'length.out'] diff --git a/R/repeat_linter.R b/R/repeat_linter.R index 8bb0e30c1..877ff0da7 100644 --- a/R/repeat_linter.R +++ b/R/repeat_linter.R @@ -24,7 +24,7 @@ repeat_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + lints <- xml_find_all(xml, xpath) xml_nodes_to_lints( diff --git a/R/return_linter.R b/R/return_linter.R index 8ef366676..a0e1c245f 100644 --- a/R/return_linter.R +++ b/R/return_linter.R @@ -3,18 +3,23 @@ #' This linter checks functions' [return()] expressions. #' #' @param return_style Character string naming the return style. `"implicit"`, -#' the default, enforeces the Tidyverse guide recommendation to leave terminal +#' the default, enforces the Tidyverse guide recommendation to leave terminal #' returns implicit. `"explicit"` style requires that `return()` always be #' explicitly supplied. +#' @param allow_implicit_else Logical, default `TRUE`. If `FALSE`, functions with a terminal +#' `if` clause must always have an `else` clause, making the `NULL` alternative explicit +#' if necessary. Similarly, functions with terminal [switch()] statements must have an +#' explicit default case. #' @param return_functions Character vector of functions that are accepted as terminal calls #' when `return_style = "explicit"`. These are in addition to exit functions #' from base that are always allowed: [stop()], [q()], [quit()], [invokeRestart()], #' `tryInvokeRestart()`, [UseMethod()], [NextMethod()], [standardGeneric()], #' [callNextMethod()], [.C()], [.Call()], [.External()], and [.Fortran()]. -#' @param except Character vector of functions that are not checked when +#' @param except,except_regex Character vector of functions that are not checked when #' `return_style = "explicit"`. These are in addition to namespace hook functions #' that are never checked: `.onLoad()`, `.onUnload()`, `.onAttach()`, `.onDetach()`, -#' `.Last.lib()`, `.First()` and `.Last()`. +#' `.Last.lib()`, `.First()` and `.Last()`. `except` matches function names exactly, +#' while `except_regex` does exclusion by pattern matching with [rex::re_matches()]. #' #' @examples #' # will produce lints @@ -32,6 +37,13 @@ #' linters = return_linter(return_style = "explicit") #' ) #' +#' code <- "function(x) {\n if (x > 0) 2\n}" +#' writeLines(code) +#' lint( +#' text = code, +#' linters = return_linter(allow_implicit_else = FALSE) +#' ) +#' #' # okay #' code <- "function(x) {\n x + 1\n}" #' writeLines(code) @@ -47,6 +59,12 @@ #' linters = return_linter(return_style = "explicit") #' ) #' +#' code <- "function(x) {\n if (x > 0) 2 else NULL\n}" +#' writeLines(code) +#' lint( +#' text = code, +#' linters = return_linter(allow_implicit_else = FALSE) +#' ) #' #' @evalRd rd_tags("return_linter") #' @seealso @@ -55,28 +73,35 @@ #' @export return_linter <- function( return_style = c("implicit", "explicit"), + allow_implicit_else = TRUE, return_functions = NULL, - except = NULL) { + except = NULL, + except_regex = NULL) { return_style <- match.arg(return_style) - if (return_style == "implicit") { - xpath <- " - (//FUNCTION | //OP-LAMBDA) - /following-sibling::expr[1][*[1][self::OP-LEFT-BRACE]] - /expr[last()][ - expr[1][ - not(OP-DOLLAR or OP-AT) - and SYMBOL_FUNCTION_CALL[text() = 'return'] - ] - ] - " - msg <- "Use implicit return behavior; explicit return() is not needed." - } else { - # See `?.onAttach`; these functions are all exclusively used for their - # side-effects, so implicit return is generally acceptable + check_except <- !allow_implicit_else || return_style == "explicit" + # We defer building the XPath strings in this case since we can't build the + # pattern-based "except" logic directly into the XPath (because of v1.0) + defer_except <- check_except && !is.null(except_regex) + if (check_except) { + except_xpath_fmt <- "parent::expr[not( + preceding-sibling::expr/SYMBOL[{ xp_text_in_table(except) }] + )]" except <- union(special_funs, except) + if (!defer_except) except_xpath <- glue(except_xpath_fmt, except = except) + } + if (return_style == "implicit") { + # nolint next: object_usage. False positive. + body_xpath <- "(//FUNCTION | //OP-LAMBDA)/following-sibling::expr[1]" + params <- list( + implicit = TRUE, + type = "style", + lint_xpath = "SYMBOL_FUNCTION_CALL[text() = 'return']", + lint_message = "Use implicit return behavior; explicit return() is not needed." + ) + } else { base_return_functions <- c( # Normal calls "return", "stop", "q", "quit", @@ -94,80 +119,130 @@ return_linter <- function( return_functions <- union(base_return_functions, return_functions) - control_calls <- c("IF", "FOR", "WHILE", "REPEAT") - - # from top, look for a FUNCTION definition that uses { (one-line - # function definitions are excepted), then look for failure to find - # return() on the last() expr of the function definition. - # exempt .onLoad which shows up in the tree like - # .onLoad... - # simple final expression (no control flow) must be - # CALL( ) - # NB: if this syntax _isn't_ used, the node may not be , hence - # the use of /*[...] below and self::expr here. position() = 1 is - # needed to guard against a few other cases. - # We also need to make sure that this expression isn't followed by a pipe - # symbol, which would indicate that we need to also check the last - # expression. - # pipe expressions are like - # ... - # %>% - # return - # - # Unlike the following case, the return should be the last expression in - # the sequence. - # conditional expressions are like - # ( ) [ ] - # we require _any_ call to return() in either of the latter two , i.e., - # we don't apply recursive logic to check every branch, only that the - # two top level branches have at least two return()s - # because of special 'in' syntax for 'for' loops, the condition is - # tagged differently than for 'if'/'while' conditions (simple PAREN) - xpath <- glue(" - (//FUNCTION | //OP-LAMBDA)[parent::expr[not( - preceding-sibling::expr[SYMBOL[{ xp_text_in_table(except) }]] - )]] + body_xpath_fmt <- " + (//FUNCTION | //OP-LAMBDA)[{ except_xpath }] /following-sibling::expr[OP-LEFT-BRACE and expr[last()]/@line1 != @line1] /expr[last()] - /*[ - ( - position() = 1 - and ( - ( - { xp_or(paste0('self::', setdiff(control_calls, 'IF'))) } - ) or ( - not({ xp_or(paste0('self::', control_calls)) }) - and not( - following-sibling::PIPE - or following-sibling::SPECIAL[text() = '%>%'] - ) - and not(self::expr/SYMBOL_FUNCTION_CALL[ - { xp_text_in_table(return_functions) } - ]) - ) - ) - ) or ( - preceding-sibling::IF - and self::expr - and position() > 4 - and not(.//SYMBOL_FUNCTION_CALL[{ xp_text_in_table(return_functions) }]) - ) - ] - ") - msg <- "All functions must have an explicit return()." + " + if (defer_except) { + function_name_xpath <- "(//FUNCTION | //OP-LAMBDA)/parent::expr/preceding-sibling::expr/SYMBOL" + } else { + body_xpath <- glue(body_xpath_fmt, except_xpath = except_xpath) + } + + params <- list( + implicit = FALSE, + type = "warning", + lint_xpath = glue("self::*[not( + (self::expr | following-sibling::SPECIAL[text() = '%>%']/following-sibling::expr/expr[1]) + /SYMBOL_FUNCTION_CALL[{ xp_text_in_table(return_functions) }] + )]"), + lint_message = "All functions must have an explicit return()." + ) } + params$allow_implicit_else <- allow_implicit_else + Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + if (defer_except) { + assigned_functions <- xml_text(xml_find_all(xml, function_name_xpath)) + except <- union(except, assigned_functions[re_matches(assigned_functions, except_regex)]) + except_xpath <- glue(except_xpath_fmt, except = except) + body_xpath <- glue(body_xpath_fmt, except_xpath = except_xpath) + } - xml_nodes <- xml_find_all(xml, xpath) + body_expr <- xml_find_all(xml, body_xpath) - xml_nodes_to_lints( - xml_nodes, - source_expression = source_expression, - lint_message = msg, - type = "style" + params$source_expression <- source_expression + + if (params$implicit && !params$allow_implicit_else) { + # can't incorporate this into the body_xpath for implicit return style, + # since we still lint explicit returns for except= functions. + allow_implicit_else <- is.na(xml_find_first(body_expr, except_xpath)) + } else { + allow_implicit_else <- rep(params$allow_implicit_else, length(body_expr)) + } + # nested_return_lints not "vectorized" due to xml_children() + Map( + function(expr, allow_implicit_else) { + params$allow_implicit_else <- allow_implicit_else + nested_return_lints(expr, params) + }, + body_expr, allow_implicit_else ) }) } + +nested_return_lints <- function(expr, params) { + child_expr <- xml_children(expr) + if (length(child_expr) == 0L) { + return(list()) + } + names(child_expr) <- xml_name(child_expr) + + if (names(child_expr)[1L] == "OP-LEFT-BRACE") { + brace_return_lints(child_expr, expr, params) + } else if (names(child_expr)[1L] == "IF") { + if_return_lints(child_expr, expr, params) + } else if (!is.na(xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL[text() = 'switch']"))) { + switch_return_lints(child_expr, expr, params) + } else { + xml_nodes_to_lints( + xml_find_first(child_expr[[1L]], params$lint_xpath), + source_expression = params$source_expression, + lint_message = params$lint_message, + type = params$type + ) + } +} + +brace_return_lints <- function(child_expr, expr, params) { + expr_idx <- which(names(child_expr) %in% c("expr", "equal_assign", "expr_or_assign_or_help")) + if (length(expr_idx) == 0L) { # empty brace expression {} + if (params$implicit) { + return(list()) + } else { + return(list(xml_nodes_to_lints( + expr, + source_expression = params$source_expression, + lint_message = params$lint_message, + type = params$type + ))) + } + } + nested_return_lints(child_expr[[tail(expr_idx, 1L)]], params) +} + +if_return_lints <- function(child_expr, expr, params) { + expr_idx <- which(names(child_expr) %in% c("expr", "equal_assign", "expr_or_assign_or_help")) + return_lints <- lapply(child_expr[expr_idx[-1L]], nested_return_lints, params) + if (params$allow_implicit_else || length(expr_idx) == 3L) { + return(return_lints) + } + implicit_else_lints <- list(xml_nodes_to_lints( + expr, + source_expression = params$source_expression, + lint_message = "All functions with terminal if statements must have a corresponding terminal else clause.", + type = "warning" + )) + c(return_lints, implicit_else_lints) +} + +switch_return_lints <- function(child_expr, expr, params) { + # equal_assign/expr_or_assign_or_help not possible here + expr_idx <- which(names(child_expr) == "expr") + # switch(x, ...) | expr[1]: switch; expr[2]: x. Drop the first two, check usage in ... + return_lints <- lapply(child_expr[tail(expr_idx, -2L)], nested_return_lints, params) + # in addition to the two dropped above, a third unmatched would be the default case. + if (params$allow_implicit_else || length(expr_idx) - sum(names(child_expr) == "EQ_SUB") == 3L) { + return(return_lints) + } + implicit_else_lints <- list(xml_nodes_to_lints( + expr, + source_expression = params$source_expression, + lint_message = "All functions with terminal switch statements must have a terminal default clause.", + type = "warning" + )) + c(return_lints, implicit_else_lints) +} diff --git a/R/routine_registration_linter.R b/R/routine_registration_linter.R index 1d0fe2e47..b6f30503f 100644 --- a/R/routine_registration_linter.R +++ b/R/routine_registration_linter.R @@ -31,15 +31,12 @@ #' - #' #' @export -routine_registration_linter <- local({ - native_routine_callers <- c(".C", ".Call", ".Fortran", ".External") - make_linter_from_xpath( - xpath = glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(native_routine_callers)} ] - /parent::expr - /following-sibling::expr[1]/STR_CONST - /parent::expr - "), - lint_message = "Register your native code routines with useDynLib and R_registerRoutines()." - ) -}) +routine_registration_linter <- make_linter_from_function_xpath( + function_names = c(".C", ".Call", ".Fortran", ".External"), + xpath = " + parent::expr + /following-sibling::expr[1]/STR_CONST + /parent::expr + ", + lint_message = "Register your native code routines with useDynLib and R_registerRoutines()." +) diff --git a/R/sample_int_linter.R b/R/sample_int_linter.R index ef76d178b..dfdee8d0e 100644 --- a/R/sample_int_linter.R +++ b/R/sample_int_linter.R @@ -39,8 +39,7 @@ sample_int_linter <- function() { # exclude TRUE/FALSE for sample(replace = TRUE, ...) usage. better # would be match.arg() but this also works. xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'sample'] - /parent::expr[not(OP-DOLLAR or OP-AT)] + parent::expr[not(OP-DOLLAR or OP-AT)] /following-sibling::expr[1][ ( expr[1]/NUM_CONST[text() = '1' or text() = '1L'] @@ -66,10 +65,9 @@ sample_int_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + xml_calls <- source_expression$xml_find_function_calls("sample") + bad_expr <- xml_find_all(xml_calls, xpath) - bad_expr <- xml_find_all(xml, xpath) first_call <- xp_call_name(bad_expr, depth = 2L) original <- sprintf("%s(n)", first_call) original[!is.na(xml_find_first(bad_expr, "expr[2]/OP-COLON"))] <- "1:n" diff --git a/R/scalar_in_linter.R b/R/scalar_in_linter.R index fb8340942..77ca70285 100644 --- a/R/scalar_in_linter.R +++ b/R/scalar_in_linter.R @@ -39,7 +39,6 @@ scalar_in_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) in_op <- xml_find_chr(bad_expr, "string(SPECIAL)") diff --git a/R/semicolon_linter.R b/R/semicolon_linter.R index 66b893e6d..5faf5e12c 100644 --- a/R/semicolon_linter.R +++ b/R/semicolon_linter.R @@ -60,8 +60,8 @@ #' - #' @export semicolon_linter <- function(allow_compound = FALSE, allow_trailing = FALSE) { - msg_trailing <- "Trailing semicolons are not needed." - msg_compound <- "Compound semicolons are discouraged. Replace them by a newline." + msg_trailing <- "Remove trailing semicolons." + msg_compound <- "Replace compound semicolons by a newline." if (allow_compound && allow_trailing) { stop( @@ -87,7 +87,7 @@ semicolon_linter <- function(allow_compound = FALSE, allow_trailing = FALSE) { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) + bad_exprs <- xml_find_all(xml, xpath) if (need_detection) { is_trailing <- is.na(xml_find_first(bad_exprs, compound_xpath)) diff --git a/R/seq_linter.R b/R/seq_linter.R index 462c0889a..decc02c66 100644 --- a/R/seq_linter.R +++ b/R/seq_linter.R @@ -50,8 +50,7 @@ seq_linter <- function() { # Exact `xpath` depends on whether bad function was used in conjunction with `seq()` seq_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'seq'] - /parent::expr + parent::expr /following-sibling::expr[1][expr/SYMBOL_FUNCTION_CALL[ {bad_funcs} ]] /parent::expr[count(expr) = 2] ") @@ -67,8 +66,6 @@ seq_linter <- function() { ] ") - xpath <- paste(seq_xpath, "|", colon_xpath) - ## The actual order of the nodes is document order ## In practice we need to handle length(x):1 get_fun <- function(expr, n) { @@ -88,9 +85,12 @@ seq_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + seq_calls <- source_expression$xml_find_function_calls("seq") - badx <- xml_find_all(xml, xpath) + badx <- combine_nodesets( + xml_find_all(seq_calls, seq_xpath), + xml_find_all(xml, colon_xpath) + ) dot_expr1 <- get_fun(badx, 1L) dot_expr2 <- get_fun(badx, 2L) @@ -104,12 +104,12 @@ seq_linter <- function() { lint_message <- ifelse( grepl("seq", dot_expr1, fixed = TRUE), sprintf( - "%s(%s) is likely to be wrong in the empty edge case. Use %s instead.", - dot_expr1, dot_expr2, replacement + "Use %s instead of %s(%s), which is likely to be wrong in the empty edge case.", + replacement, dot_expr1, dot_expr2 ), sprintf( - "%s:%s is likely to be wrong in the empty edge case. Use %s instead.", - dot_expr1, dot_expr2, replacement + "Use %s instead of %s:%s, which is likely to be wrong in the empty edge case.", + replacement, dot_expr1, dot_expr2 ) ) diff --git a/R/settings.R b/R/settings.R index d696ad4a1..167fcd6ac 100644 --- a/R/settings.R +++ b/R/settings.R @@ -37,7 +37,7 @@ #' whereas the DCF approach requires somewhat awkward formatting of parseable R code within #' valid DCF key-value pairs. The main disadvantage of the R file is it might be _too_ flexible, #' with users tempted to write configs with side effects causing hard-to-detect bugs or -#" otherwise "abusing" the ability to evaluate generic R code. Other recursive key-value stores +# " otherwise "abusing" the ability to evaluate generic R code. Other recursive key-value stores #' like YAML could work, but require new dependencies and are harder to parse #' both programmatically and visually. #' Here is an example of a `.lintr.R` file: diff --git a/R/settings_utils.R b/R/settings_utils.R index a04ef5b55..9489ea24e 100644 --- a/R/settings_utils.R +++ b/R/settings_utils.R @@ -75,7 +75,7 @@ find_config <- function(filename) { # may exist in subsequent directories are ignored file_locations <- c( # Local (incl. parent) directories - find_local_config(path, basename(linter_file)), + find_local_config(path, linter_file), # User directory # cf: rstudio@bc9b6a5 SessionRSConnect.R#L32 file.path(Sys.getenv("HOME", unset = "~"), linter_file), diff --git a/R/shared_constants.R b/R/shared_constants.R index c21412dea..006c8f2fd 100644 --- a/R/shared_constants.R +++ b/R/shared_constants.R @@ -34,6 +34,7 @@ rx_static_token <- local({ rx_unescaped_regex <- paste0("(?s)", rex(start, zero_or_more(rx_non_active_char), end)) rx_static_regex <- paste0("(?s)", rex(start, zero_or_more(rx_static_token), end)) rx_first_static_token <- paste0("(?s)", rex(start, zero_or_more(rx_non_active_char), rx_static_escape)) +rx_escapable_tokens <- "^${}().*+?|[]\\<>=:;/_-!@#%&,~" #' Determine whether a regex pattern actually uses regex patterns #' @@ -95,19 +96,17 @@ get_fixed_string <- function(static_regex) { #' #' @noRd get_token_replacement <- function(token_content, token_type) { - if (token_type == "trivial_char_group") { + if (token_type == "trivial_char_group") { # otherwise, char_escape token_content <- substr(token_content, start = 2L, stop = nchar(token_content) - 1L) if (startsWith(token_content, "\\")) { # escape within trivial char group get_token_replacement(token_content, "char_escape") } else { token_content } - } else { # char_escape token - if (re_matches(token_content, rex("\\", one_of("^${}().*+?|[]\\<>=:;/_-!@#%&,~")))) { - substr(token_content, start = 2L, stop = nchar(token_content)) - } else { - eval(parse(text = paste0('"', token_content, '"'))) - } + } else if (re_matches(token_content, rex("\\", one_of(rx_escapable_tokens)))) { + substr(token_content, start = 2L, stop = nchar(token_content)) + } else { + eval(parse(text = paste0('"', token_content, '"'))) } } @@ -243,18 +242,7 @@ extract_glued_symbols <- function(expr, interpret_glue) { if (!isTRUE(interpret_glue)) { return(character()) } - # TODO support more glue functions - # Package glue: - # - glue_sql - # - glue_safe - # - glue_col - # - glue_data - # - glue_data_sql - # - glue_data_safe - # - glue_data_col - # - # Package stringr: - # - str_interp + # TODO(#2448): support more glue functions # NB: position() > 1 because position=1 is glue_call_xpath <- " descendant::SYMBOL_FUNCTION_CALL[text() = 'glue'] @@ -268,7 +256,7 @@ extract_glued_symbols <- function(expr, interpret_glue) { glued_symbols <- new.env(parent = emptyenv()) for (glue_call in glue_calls) { - # TODO(michaelchirico): consider dropping tryCatch() here if we're more confident in our logic + # TODO(#2475): Drop tryCatch(). parsed_call <- tryCatch(xml2lang(glue_call), error = unexpected_glue_parse_error, warning = unexpected_glue_parse_error) parsed_call[[".envir"]] <- glued_symbols @@ -309,3 +297,22 @@ purrr_mappers <- c( "map_raw", "map_lgl", "map_int", "map_dbl", "map_chr", "map_vec", "map_df", "map_dfr", "map_dfc" ) + +# see ?".onLoad", ?Startup, and ?quit. +# All of .onLoad, .onAttach, and .onUnload are used in base packages, +# and should be caught in is_base_function; they're included here for completeness / stability +# (they don't strictly _have_ to be defined in base, so could in principle be removed). +# .Last.sys and .First.sys are part of base itself, so aren't included here. +special_funs <- c( + ".onLoad", + ".onAttach", + ".onUnload", + ".onDetach", + ".Last.lib", + ".First", + ".Last" +) + +is_special_function <- function(x) { + x %in% special_funs +} diff --git a/R/sort_linter.R b/R/sort_linter.R index 7a3b4315f..d4709370d 100644 --- a/R/sort_linter.R +++ b/R/sort_linter.R @@ -83,8 +83,7 @@ sort_linter <- function() { ") sorted_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'sort'] - /parent::expr + parent::expr /parent::expr[not(SYMBOL_SUB)] /parent::expr[ (EQ or NE) @@ -100,7 +99,6 @@ sort_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) order_expr <- xml_find_all(xml, order_xpath) @@ -127,11 +125,16 @@ sort_linter <- function() { order_lints <- xml_nodes_to_lints( order_expr, source_expression = source_expression, - lint_message = paste0(new_call, " is better than ", orig_call, "."), + lint_message = paste0( + new_call, " is better than ", orig_call, ". ", + "Note that it's always preferable to save the output of order() for the same variable ", + "as a local variable than to re-compute it." + ), type = "warning" ) - sorted_expr <- xml_find_all(xml, sorted_xpath) + xml_calls <- source_expression$xml_find_function_calls("sort") + sorted_expr <- xml_find_all(xml_calls, sorted_xpath) sorted_op <- xml_text(xml_find_first(sorted_expr, "*[2]")) lint_message <- ifelse( diff --git a/R/source_utils.R b/R/source_utils.R new file mode 100644 index 000000000..3179847af --- /dev/null +++ b/R/source_utils.R @@ -0,0 +1,23 @@ +#' Build the `xml_find_function_calls()` helper for a source expression +#' +#' @param xml The XML parse tree as an XML object (`xml_parsed_content` or `full_xml_parsed_content`) +#' +#' @return A fast function to query +#' `xml_find_all(xml, glue::glue("//SYMBOL_FUNCTION_CALL[text() = '{function_names[1]}' or ...]"))`, +#' or, using the internal function `xp_text_in_table()`, +#' `xml_find_all(xml, glue::glue("//SYMBOL_FUNCTION_CALL[{ xp_text_in_table(function_names) }]"))`. +#' +#' @noRd +build_xml_find_function_calls <- function(xml) { + function_call_cache <- xml_find_all(xml, "//SYMBOL_FUNCTION_CALL") + names(function_call_cache) <- get_r_string(function_call_cache) + + function(function_names, keep_names = FALSE) { + if (is.null(function_names)) { + res <- function_call_cache + } else { + res <- function_call_cache[names(function_call_cache) %in% function_names] + } + if (keep_names) res else unname(res) + } +} diff --git a/R/spaces_inside_linter.R b/R/spaces_inside_linter.R index 6c1826678..7d114883c 100644 --- a/R/spaces_inside_linter.R +++ b/R/spaces_inside_linter.R @@ -54,7 +54,6 @@ spaces_inside_linter <- function() { Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) left_expr <- xml_find_all(xml, left_xpath) left_msg <- ifelse( diff --git a/R/sprintf_linter.R b/R/sprintf_linter.R index d0f24f0fb..910d147e5 100644 --- a/R/sprintf_linter.R +++ b/R/sprintf_linter.R @@ -28,8 +28,7 @@ #' @export sprintf_linter <- function() { call_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'sprintf' or text() = 'gettextf'] - /parent::expr + parent::expr /parent::expr[ ( OP-LEFT-PAREN/following-sibling::expr[1]/STR_CONST or @@ -105,10 +104,8 @@ sprintf_linter <- function() { } Linter(linter_level = "file", function(source_expression) { - xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) - - sprintf_calls <- xml_find_all(xml, call_xpath) + xml_calls <- source_expression$xml_find_function_calls(c("sprintf", "gettextf")) + sprintf_calls <- xml_find_all(xml_calls, call_xpath) sprintf_warning <- vapply(sprintf_calls, capture_sprintf_warning, character(1L)) diff --git a/R/stopifnot_all_linter.R b/R/stopifnot_all_linter.R index f081cc0c0..499d66e22 100644 --- a/R/stopifnot_all_linter.R +++ b/R/stopifnot_all_linter.R @@ -29,15 +29,15 @@ #' @evalRd rd_tags("stopifnot_all_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -stopifnot_all_linter <- make_linter_from_xpath( +stopifnot_all_linter <- make_linter_from_function_xpath( + function_names = "stopifnot", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'stopifnot'] - /parent::expr + parent::expr /parent::expr /expr[expr/SYMBOL_FUNCTION_CALL[text() = 'all']] ", lint_message = paste( - "Calling stopifnot(all(x)) is redundant. stopifnot(x) runs all()", - "'under the hood' and provides a better error message in case of failure." + "Use stopifnot(x) instead of stopifnot(all(x)).", + "stopifnot(x) runs all() 'under the hood' and provides a better error message in case of failure." ) ) diff --git a/R/string_boundary_linter.R b/R/string_boundary_linter.R index 9813f8564..fe3727b9e 100644 --- a/R/string_boundary_linter.R +++ b/R/string_boundary_linter.R @@ -61,16 +61,19 @@ string_boundary_linter <- function(allow_grepl = FALSE) { "contains(text(), '^') or contains(text(), '$')" ) str_detect_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'str_detect'] - /parent::expr + parent::expr /following-sibling::expr[2] /STR_CONST[ {str_cond} ] ") + str_detect_message_map <- c( + both = "Use == to check for an exact string match.", + initial = "Use startsWith() to detect a fixed initial substring.", + terminal = "Use endsWith() to detect a fixed terminal substring." + ) if (!allow_grepl) { grepl_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'grepl'] - /parent::expr + parent::expr /parent::expr[ not(SYMBOL_SUB[ text() = 'ignore.case' @@ -84,20 +87,38 @@ string_boundary_linter <- function(allow_grepl = FALSE) { /expr[2] /STR_CONST[ {str_cond} ] ") + grepl_lint_fmt <- paste( + "Use !is.na(x) & %1$s(x, string) to detect a fixed %2$s substring, or,", + "if missingness is not a concern, just %1$s()." + ) + grepl_message_map <- c( + both = "Use == to check for an exact string match.", + initial = sprintf(grepl_lint_fmt, "startsWith", "initial"), + terminal = sprintf(grepl_lint_fmt, "endsWith", "terminal") + ) } get_regex_lint_data <- function(xml, xpath) { expr <- xml_find_all(xml, xpath) patterns <- get_r_string(expr) initial_anchor <- startsWith(patterns, "^") + terminal_anchor <- endsWith(patterns, "$") search_start <- 1L + initial_anchor - search_end <- nchar(patterns) - 1L + initial_anchor + search_end <- nchar(patterns) - terminal_anchor can_replace <- is_not_regex(substr(patterns, search_start, search_end)) - list(lint_expr = expr[can_replace], initial_anchor = initial_anchor[can_replace]) + initial_anchor <- initial_anchor[can_replace] + terminal_anchor <- terminal_anchor[can_replace] + + lint_type <- character(length(initial_anchor)) + + lint_type[initial_anchor & terminal_anchor] <- "both" + lint_type[initial_anchor & !terminal_anchor] <- "initial" + lint_type[!initial_anchor & terminal_anchor] <- "terminal" + list(lint_expr = expr[can_replace], lint_type = lint_type) } - substr_xpath_parts <- glue(" - //{ c('EQ', 'NE') } + substr_xpath <- glue(" + (//EQ | //NE) /parent::expr[ expr[STR_CONST] and expr[ @@ -115,48 +136,35 @@ string_boundary_linter <- function(allow_grepl = FALSE) { ] ] ") - substr_xpath <- paste(substr_xpath_parts, collapse = " | ") substr_arg2_xpath <- "string(./expr[expr[1][SYMBOL_FUNCTION_CALL]]/expr[3])" Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + lints <- list() - str_detect_lint_data <- get_regex_lint_data(xml, str_detect_xpath) - str_detect_lint_message <- paste( - ifelse( - str_detect_lint_data$initial_anchor, - "Use startsWith() to detect a fixed initial substring.", - "Use endsWith() to detect a fixed terminal substring." - ), - "Doing so is more readable and more efficient." + str_detect_lint_data <- get_regex_lint_data( + source_expression$xml_find_function_calls("str_detect"), + str_detect_xpath ) + str_detect_lint_message <- str_detect_message_map[str_detect_lint_data$lint_type] lints <- c(lints, xml_nodes_to_lints( str_detect_lint_data$lint_expr, source_expression = source_expression, - lint_message = str_detect_lint_message, + lint_message = paste(str_detect_lint_message, "Doing so is more readable and more efficient."), type = "warning" )) if (!allow_grepl) { - grepl_lint_data <- get_regex_lint_data(xml, grepl_xpath) - grepl_replacement <- ifelse(grepl_lint_data$initial_anchor, "startsWith", "endsWith") - grepl_type <- ifelse(grepl_lint_data$initial_anchor, "initial", "terminal") - grepl_lint_message <- paste( - sprintf( - "Use !is.na(x) & %s(x, string) to detect a fixed %s substring, or, if missingness is not a concern, just %s.", - grepl_replacement, grepl_type, grepl_replacement - ), - "Doing so is more readable and more efficient." - ) + grepl_lint_data <- get_regex_lint_data(source_expression$xml_find_function_calls("grepl"), grepl_xpath) + grepl_lint_message <- grepl_message_map[grepl_lint_data$lint_type] lints <- c(lints, xml_nodes_to_lints( grepl_lint_data$lint_expr, source_expression = source_expression, - lint_message = grepl_lint_message, + lint_message = paste(grepl_lint_message, "Doing so is more readable and more efficient."), type = "warning" )) } diff --git a/R/strings_as_factors_linter.R b/R/strings_as_factors_linter.R index e4cf535fd..577ab7c74 100644 --- a/R/strings_as_factors_linter.R +++ b/R/strings_as_factors_linter.R @@ -39,7 +39,7 @@ #' @evalRd rd_tags("strings_as_factors_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -strings_as_factors_linter <- function() { +strings_as_factors_linter <- local({ # a call to c() with only literal string inputs, # e.g. c("a") or c("a", "b"), but not c("a", b) c_combine_strings <- " @@ -63,8 +63,7 @@ strings_as_factors_linter <- function() { # (1) above argument is to row.names= # (2) stringsAsFactors is manually supplied (with any value) xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'data.frame'] - /parent::expr + parent::expr /parent::expr[ expr[ ( @@ -82,22 +81,11 @@ strings_as_factors_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) - - xml_nodes_to_lints( - bad_expr, - source_expression = source_expression, - lint_message = paste( - "This code relies on the default value of stringsAsFactors,", - "which changed in version R 4.0. Please supply an explicit value for", - "stringsAsFactors for this code to work with versions of R both before", - "and after this switch." - ), - type = "warning" - ) - }) -} + make_linter_from_function_xpath( + function_names = "data.frame", + xpath = xpath, + lint_message = + "Supply an explicit value for stringsAsFactors for this code to work before and after R version 4.0.", + type = "warning" + ) +}) diff --git a/R/system_file_linter.R b/R/system_file_linter.R index 0e8081c5d..24fba540e 100644 --- a/R/system_file_linter.R +++ b/R/system_file_linter.R @@ -25,20 +25,24 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export system_file_linter <- function() { - funs <- c("system.file", "file.path") # either system.file(file.path(...)) or file.path(system.file(...)) - xpath_parts <- glue(" - //SYMBOL_FUNCTION_CALL[text() = '{funs}'] - /parent::expr[following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = '{rev(funs)}']] + file_path_xpath <- " + parent::expr[following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'system.file']] /parent::expr - ") - xpath <- paste(xpath_parts, collapse = " | ") + " + system_file_xpath <- " + parent::expr[following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'file.path']] + /parent::expr + " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + file_path_calls <- source_expression$xml_find_function_calls("file.path") + system_file_calls <- source_expression$xml_find_function_calls("system.file") - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- combine_nodesets( + xml_find_all(file_path_calls, file_path_xpath), + xml_find_all(system_file_calls, system_file_xpath) + ) outer_call <- xp_call_name(bad_expr) lint_message <- paste( diff --git a/R/terminal_close_linter.R b/R/terminal_close_linter.R index 4b8a3ede3..20b86ac64 100644 --- a/R/terminal_close_linter.R +++ b/R/terminal_close_linter.R @@ -49,8 +49,5 @@ terminal_close_linter <- make_linter_from_xpath( ] ] ", - lint_message = paste( - "Use on.exit(close(x)) to close connections instead of", - "running it as the last call in a function." - ) + lint_message = "Use on.exit(close(x)) to close connections instead of running it as the last call in a function." ) diff --git a/R/todo_comment_linter.R b/R/todo_comment_linter.R new file mode 100644 index 000000000..16e1de05f --- /dev/null +++ b/R/todo_comment_linter.R @@ -0,0 +1,72 @@ +#' TODO comment linter +#' +#' Check that the source contains no TODO comments (case-insensitive). +#' +#' @param todo Vector of case-insensitive strings that identify TODO comments. +#' @param except_regex Vector of case-sensitive regular expressions that identify +#' _valid_ TODO comments. +#' +#' @examples +#' # will produce lints +#' lint( +#' text = "x + y # TOODOO", +#' linters = todo_comment_linter(todo = "toodoo") +#' ) +#' +#' lint( +#' text = "pi <- 1.0 # FIIXMEE", +#' linters = todo_comment_linter(todo = "fiixmee") +#' ) +#' +#' lint( +#' text = "x <- TRUE # TOODOO(#1234): Fix this hack.", +#' linters = todo_comment_linter() +#' ) +#' +#' # okay +#' lint( +#' text = "x + y # my informative comment", +#' linters = todo_comment_linter() +#' ) +#' +#' lint( +#' text = "pi <- 3.14", +#' linters = todo_comment_linter() +#' ) +#' +#' lint( +#' text = "x <- TRUE", +#' linters = todo_comment_linter() +#' ) +#' +#' lint( +#' text = "x <- TRUE # TODO(#1234): Fix this hack.", +#' linters = todo_comment_linter(except_regex = "TODO\\(#[0-9]+\\):") +#' ) +#' +#' @evalRd rd_tags("todo_comment_linter") +#' @seealso [linters] for a complete list of linters available in lintr. +#' @export +todo_comment_linter <- function(todo = c("todo", "fixme"), except_regex = NULL) { + todo_comment_regex <- rex(one_or_more("#"), any_spaces, or(todo)) + valid_todo_regex <- + if (!is.null(except_regex)) paste0("#+", rex::shortcuts$any_spaces, "(?:", paste(except_regex, collapse = "|"), ")") + + Linter(linter_level = "expression", function(source_expression) { + xml <- source_expression$xml_parsed_content + + comment_expr <- xml_find_all(xml, "//COMMENT") + comment_text <- xml_text(comment_expr) + invalid_todo <- re_matches(comment_text, todo_comment_regex, ignore.case = TRUE) + if (!is.null(valid_todo_regex)) { + invalid_todo <- invalid_todo & !re_matches(comment_text, valid_todo_regex) + } + + xml_nodes_to_lints( + comment_expr[invalid_todo], + source_expression = source_expression, + lint_message = "Remove TODO comments.", + type = "style" + ) + }) +} diff --git a/R/trailing_blank_lines_linter.R b/R/trailing_blank_lines_linter.R index 3479a8b58..023bfda1a 100644 --- a/R/trailing_blank_lines_linter.R +++ b/R/trailing_blank_lines_linter.R @@ -2,22 +2,25 @@ #' #' Check that there are no trailing blank lines in source code. #' -#' @examplesIf requireNamespace("withr", quietly = TRUE) +#' @examples #' # will produce lints -#' f <- withr::local_tempfile(lines = "x <- 1\n") -#' readLines(f) +#' f <- tempfile() +#' cat("x <- 1\n\n", file = f) +#' writeLines(readChar(f, file.size(f))) #' lint( #' filename = f, #' linters = trailing_blank_lines_linter() #' ) +#' unlink(f) #' #' # okay -#' f <- withr::local_tempfile(lines = "x <- 1") -#' readLines(f) +#' cat("x <- 1\n", file = f) +#' writeLines(readChar(f, file.size(f))) #' lint( #' filename = f, #' linters = trailing_blank_lines_linter() #' ) +#' unlink(f) #' #' @evalRd rd_tags("trailing_blank_lines_linter") #' @seealso [linters] for a complete list of linters available in lintr. @@ -38,7 +41,7 @@ trailing_blank_lines_linter <- function() { line_number = line_number, column_number = 1L, type = "style", - message = "Trailing blank lines are superfluous.", + message = "Remove trailing blank lines.", line = source_expression$file_lines[[line_number]] ) } @@ -53,7 +56,7 @@ trailing_blank_lines_linter <- function() { line_number = length(source_expression$file_lines), column_number = (nchar(last_line) %||% 0L) + 1L, type = "style", - message = "Missing terminal newline.", + message = "Add a terminal newline.", line = last_line ) } diff --git a/R/trailing_whitespace_linter.R b/R/trailing_whitespace_linter.R index fec39dcba..ba1e5ef25 100644 --- a/R/trailing_whitespace_linter.R +++ b/R/trailing_whitespace_linter.R @@ -71,7 +71,7 @@ trailing_whitespace_linter <- function(allow_empty_lines = FALSE, allow_in_strin line_number = line, column_number = res$start[[line]], type = "style", - message = "Trailing whitespace is superfluous.", + message = "Remove trailing whitespace.", line = source_expression$file_lines[[line]], ranges = list(c(res$start[[line]], res$end[[line]])) ) diff --git a/R/undesirable_function_linter.R b/R/undesirable_function_linter.R index d157b3963..762ecda5d 100644 --- a/R/undesirable_function_linter.R +++ b/R/undesirable_function_linter.R @@ -66,7 +66,6 @@ undesirable_function_linter <- function(fun = default_undesirable_functions, } xp_condition <- xp_and( - xp_text_in_table(names(fun)), paste0( "not(parent::expr/preceding-sibling::expr[last()][SYMBOL_FUNCTION_CALL[", xp_text_in_table(c("library", "require")), @@ -76,22 +75,25 @@ undesirable_function_linter <- function(fun = default_undesirable_functions, ) if (symbol_is_undesirable) { - xpath <- glue("//SYMBOL_FUNCTION_CALL[{xp_condition}] | //SYMBOL[{xp_condition}]") - } else { - xpath <- glue("//SYMBOL_FUNCTION_CALL[{xp_condition}]") + symbol_xpath <- glue("//SYMBOL[({xp_text_in_table(names(fun))}) and {xp_condition}]") } - + xpath <- glue("self::SYMBOL_FUNCTION_CALL[{xp_condition}]") Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - matched_nodes <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(names(fun)) + + matched_nodes <- xml_find_all(xml_calls, xpath) + if (symbol_is_undesirable) { + matched_nodes <- combine_nodesets(matched_nodes, xml_find_all(xml, symbol_xpath)) + } + fun_names <- get_r_string(matched_nodes) msgs <- vapply( stats::setNames(nm = unique(fun_names)), function(fun_name) { - msg <- sprintf('Function "%s" is undesirable.', fun_name) + msg <- sprintf('Avoid undesirable function "%s".', fun_name) alternative <- fun[[fun_name]] if (!is.na(alternative)) { msg <- paste(msg, sprintf("As an alternative, %s.", alternative)) diff --git a/R/undesirable_operator_linter.R b/R/undesirable_operator_linter.R index e25ab27f1..734e6c485 100644 --- a/R/undesirable_operator_linter.R +++ b/R/undesirable_operator_linter.R @@ -68,12 +68,11 @@ undesirable_operator_linter <- function(op = default_undesirable_operators) { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_op <- xml_find_all(xml, xpath) operator <- xml_text(bad_op) - lint_message <- sprintf("Operator `%s` is undesirable.", operator) + lint_message <- sprintf("Avoid undesirable operator `%s`.", operator) alternative <- op[operator] has_alternative <- !is.na(alternative) lint_message[has_alternative] <- paste(lint_message[has_alternative], alternative[has_alternative]) diff --git a/R/unnecessary_concatenation_linter.R b/R/unnecessary_concatenation_linter.R index 3571e5faf..326200c32 100644 --- a/R/unnecessary_concatenation_linter.R +++ b/R/unnecessary_concatenation_linter.R @@ -57,13 +57,10 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { # length(allow_single_expression) == 1L ) - msg_empty <- paste( - "Unneeded concatenation without arguments.", - 'Replace the "c" call by NULL or, whenever possible,', - "vector() seeded with the correct type and/or length." - ) + msg_empty <- + "Replace unnecessary c() by NULL or, whenever possible, vector() seeded with the correct type and/or length." - msg_const <- 'Unneeded concatenation of a constant. Remove the "c" call.' + msg_const <- "Remove unnecessary c() of a constant." non_constant_cond <- "SYMBOL or (expr and not(OP-COLON and count(expr[SYMBOL or expr]) != 2))" @@ -85,13 +82,12 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { # path_to_non_constant <- glue("./expr[2][ {non_constant_cond} ]") msg_const_expr <- paste( - 'Unneeded concatenation of a simple expression. Remove the "c" call,', - 'replacing with "as.vector" if using "c" to string attributes, e.g. in converting an array to a vector.' + "Remove unnecessary c() of a constant expression.", + "Replace with as.vector() if c() is used to strip attributes, e.g. in converting an array to a vector." ) } call_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'c'] - /parent::expr + parent::expr /parent::expr[ not(EQ_SUB) and ( {xp_or(zero_arg_cond, one_arg_cond)} ) @@ -100,16 +96,15 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { # num_args_xpath <- "count(./expr) - 1" Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - c_calls <- xml_find_all(xml, call_xpath) + xml_calls <- source_expression$xml_find_function_calls("c") + c_calls <- xml_find_all(xml_calls, call_xpath) # bump count(args) by 1 if inside a pipeline num_args <- as.integer(xml_find_num(c_calls, num_args_xpath)) + as.integer(!is.na(xml_find_first(c_calls, to_pipe_xpath))) # NB: the xpath guarantees num_args is 0, 1, or 2. 2 comes # in "a" %>% c("b"). - # TODO(michaelchirico): can we handle this all inside the XPath with reasonable concision? + # TODO(#2476): Push this logic back into the XPath. is_unneeded <- num_args <= 1L c_calls <- c_calls[is_unneeded] num_args <- num_args[is_unneeded] diff --git a/R/unnecessary_lambda_linter.R b/R/unnecessary_lambda_linter.R index 023867d59..8e43bb267 100644 --- a/R/unnecessary_lambda_linter.R +++ b/R/unnecessary_lambda_linter.R @@ -80,20 +80,19 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # call is using positional or keyword arguments -- we can # throw a lint for sweep() lambdas where the following arguments # are all named) but for now it seems like overkill. - apply_funs <- xp_text_in_table(c( # nolint: object_usage_linter. Used in glue call below. + apply_funs <- c( "lapply", "sapply", "vapply", "apply", "tapply", "rapply", "eapply", "dendrapply", "mapply", "by", "outer", "mclapply", "mcmapply", "parApply", "parCapply", "parLapply", "parLapplyLB", "parRapply", "parSapply", "parSapplyLB", "pvec", purrr_mappers - )) + ) # OP-PLUS: condition for complex literal, e.g. 0+2i. # NB: this includes 0+3 and TRUE+FALSE, which are also fine. inner_comparison_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'sapply' or text() = 'vapply'] - /parent::expr + parent::expr /parent::expr /expr[FUNCTION] /expr[ @@ -113,14 +112,13 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # outline: # 1. match one of the identified mappers # 2. match an anonymous function that can be "symbol-ized" - # a. it's a one-variable function [TODO(michaelchirico): is this necessary?] + # a. it's a one-variable function [TODO(#2477): relax this] # b. the function is a single call # c. that call's _first_ argument is just the function argument (a SYMBOL) # - and it has to be passed positionally (not as a keyword) # d. the function argument doesn't appear elsewhere in the call default_fun_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {apply_funs} ] - /parent::expr + parent::expr /following-sibling::expr[(FUNCTION or OP-LAMBDA) and count(SYMBOL_FORMALS) = 1] /expr[last()][ count(.//SYMBOL[self::* = preceding::SYMBOL_FORMALS[1]]) = 1 @@ -145,8 +143,7 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # 2. the lone argument marker `.x` or `.` purrr_symbol <- "SYMBOL[text() = '.x' or text() = '.']" purrr_fun_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(purrr_mappers)} ] - /parent::expr + parent::expr /following-sibling::expr[ OP-TILDE and expr[OP-LEFT-PAREN/following-sibling::expr[1][not(preceding-sibling::*[2][self::SYMBOL_SUB])]/{purrr_symbol}] @@ -160,16 +157,10 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { symbol_xpath <- "expr[last()]//expr[SYMBOL_FUNCTION_CALL[text() != 'return']]" Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - default_fun_expr <- xml_find_all(xml, default_fun_xpath) + default_calls <- source_expression$xml_find_function_calls(apply_funs) + default_fun_expr <- xml_find_all(default_calls, default_fun_xpath) - # TODO(michaelchirico): further message customization is possible here, - # e.g. don't always refer to 'lapply()' in the example, and customize to - # whether arguments need to be subsumed in '...' or not. The trouble is in - # keeping track of which argument the anonymous function is supplied (2nd - # argument for many calls, but 3rd e.g. for apply()) + # TODO(#2478): Give a specific recommendation in the message. default_call_fun <- xml_text(xml_find_first(default_fun_expr, fun_xpath)) default_symbol <- xml_text(xml_find_first(default_fun_expr, symbol_xpath)) default_fun_lints <- xml_nodes_to_lints( @@ -185,7 +176,8 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { inner_comparison_lints <- NULL if (!allow_comparison) { - inner_comparison_expr <- xml_find_all(xml, inner_comparison_xpath) + sapply_vapply_calls <- source_expression$xml_find_function_calls(c("sapply", "vapply")) + inner_comparison_expr <- xml_find_all(sapply_vapply_calls, inner_comparison_xpath) mapper <- xp_call_name(xml_find_first(inner_comparison_expr, "parent::expr/parent::expr")) if (length(mapper) > 0L) fun_value <- if (mapper == "sapply") "" else ", FUN.VALUE = " @@ -204,7 +196,8 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { ) } - purrr_fun_expr <- xml_find_all(xml, purrr_fun_xpath) + purrr_calls <- source_expression$xml_find_function_calls(purrr_mappers) + purrr_fun_expr <- xml_find_all(purrr_calls, purrr_fun_xpath) purrr_call_fun <- xml_text(xml_find_first(purrr_fun_expr, fun_xpath)) purrr_symbol <- xml_text(xml_find_first(purrr_fun_expr, symbol_xpath)) diff --git a/R/unnecessary_nested_if_linter.R b/R/unnecessary_nested_if_linter.R deleted file mode 100644 index 5702fc7d7..000000000 --- a/R/unnecessary_nested_if_linter.R +++ /dev/null @@ -1,44 +0,0 @@ -#' Avoid unnecessary nested `if` conditional statements -#' -#' @examples -#' # will produce lints -#' writeLines("if (x) { \n if (y) { \n return(1L) \n } \n}") -#' lint( -#' text = "if (x) { \n if (y) { \n return(1L) \n } \n}", -#' linters = unnecessary_nested_if_linter() -#' ) -#' -#' # okay -#' writeLines("if (x && y) { \n return(1L) \n}") -#' lint( -#' text = "if (x && y) { \n return(1L) \n}", -#' linters = unnecessary_nested_if_linter() -#' ) -#' -#' writeLines("if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}") -#' lint( -#' text = "if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}", -#' linters = unnecessary_nested_if_linter() -#' ) -#' -#' @evalRd rd_tags("unnecessary_nested_if_linter") -#' @seealso [linters] for a complete list of linters available in lintr. -#' @export -unnecessary_nested_if_linter <- make_linter_from_xpath( - xpath = paste0( - "//IF/parent::expr[not(ELSE)]/OP-RIGHT-PAREN/", - c( - "following-sibling::expr[IF and not(ELSE)]", # catch if (cond) if (other_cond) { ... } - "following-sibling::expr[OP-LEFT-BRACE and count(expr) = 1] - /expr[IF and not(ELSE)]" # catch if (cond) { if (other_cond) { ... } } - ), - collapse = " | " - ), - lint_message = paste( - "Don't use nested `if` statements,", - "where a single `if` with the combined conditional expression will do.", - "For example, instead of `if (x) { if (y) { ... }}`, use `if (x && y) { ... }`." - ), - # need the full file to also catch usages at the top level - level = "file" -) diff --git a/R/unnecessary_nesting_linter.R b/R/unnecessary_nesting_linter.R index a7676c37b..0fdbe61fa 100644 --- a/R/unnecessary_nesting_linter.R +++ b/R/unnecessary_nesting_linter.R @@ -9,6 +9,12 @@ #' The `TRUE` case facilitates interaction with [implicit_assignment_linter()] #' for certain cases where an implicit assignment is necessary, so a braced #' assignment is used to further distinguish the assignment. See examples. +#' @param allow_functions Character vector of functions which always allow +#' one-child braced expressions. `testthat::test_that()` is always allowed because +#' testthat requires a braced expression in its `code` argument. The other defaults +#' similarly compute on expressions in a way which is worth highlighting by +#' em-bracing them, even if there is only one expression, while [switch()] is allowed +#' for its use as a control flow analogous to `if`/`else`. #' #' @examples #' # will produce lints @@ -33,6 +39,17 @@ #' linters = unnecessary_nesting_linter(allow_assignment = FALSE) #' ) #' +#' writeLines("if (x) { \n if (y) { \n return(1L) \n } \n}") +#' lint( +#' text = "if (x) { \n if (y) { \n return(1L) \n } \n}", +#' linters = unnecessary_nesting_linter() +#' ) +#' +#' lint( +#' text = "my_quote({x})", +#' linters = unnecessary_nesting_linter() +#' ) +#' #' # okay #' code <- "if (A) {\n stop('A is bad because a.')\n} else {\n stop('!A is bad too.')\n}" #' writeLines(code) @@ -55,12 +72,39 @@ #' linters = unnecessary_nesting_linter() #' ) #' +#' writeLines("if (x && y) { \n return(1L) \n}") +#' lint( +#' text = "if (x && y) { \n return(1L) \n}", +#' linters = unnecessary_nesting_linter() +#' ) +#' +#' writeLines("if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}") +#' lint( +#' text = "if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}", +#' linters = unnecessary_nesting_linter() +#' ) +#' +#' lint( +#' text = "my_quote({x})", +#' linters = unnecessary_nesting_linter(allow_functions = "my_quote") +#' ) +#' #' @evalRd rd_tags("unnecessary_nesting_linter") #' @seealso #' - [cyclocomp_linter()] for another linter that penalizes overly complexcode. #' - [linters] for a complete list of linters available in lintr. #' @export -unnecessary_nesting_linter <- function(allow_assignment = TRUE) { +unnecessary_nesting_linter <- function( + allow_assignment = TRUE, + allow_functions = c( + "switch", + "try", "tryCatch", "withCallingHandlers", + "quote", "expression", "bquote", "substitute", + "with_parameters_test_that", + "reactive", "observe", "observeEvent", + "renderCachedPlot", "renderDataTable", "renderImage", "renderPlot", + "renderPrint", "renderTable", "renderText", "renderUI" + )) { exit_calls <- c("stop", "return", "abort", "quit", "q") exit_call_expr <- glue(" expr[SYMBOL_FUNCTION_CALL[{xp_text_in_table(exit_calls)}]] @@ -127,6 +171,7 @@ unnecessary_nesting_linter <- function(allow_assignment = TRUE) { or self::IF or self::WHILE or self::REPEAT + or self::expr/SYMBOL_FUNCTION_CALL[{ xp_text_in_table(c('test_that', allow_functions)) }] or self::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'foreach'] or self::OP-TILDE or self::LEFT_ASSIGN[text() = ':='] @@ -141,9 +186,21 @@ unnecessary_nesting_linter <- function(allow_assignment = TRUE) { ] ") + unnecessary_nested_if_xpath <- paste0( + "//IF/parent::expr[not(ELSE)]/OP-RIGHT-PAREN/", + c( + # catch if (cond) if (other_cond) { ... } + "following-sibling::expr[IF and not(ELSE)]", + # catch if (cond) { if (other_cond) { ... } } + "following-sibling::expr[OP-LEFT-BRACE and count(expr) = 1]/expr[IF and not(ELSE)]" + ), + collapse = " | " + ) + + unnecessary_else_brace_xpath <- "//IF/parent::expr[parent::expr[preceding-sibling::ELSE and count(expr) = 1]]" + Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) if_else_exit_expr <- xml_find_all(xml, if_else_exit_xpath) if_else_exit_lints <- xml_nodes_to_lints( @@ -166,6 +223,25 @@ unnecessary_nesting_linter <- function(allow_assignment = TRUE) { type = "warning" ) - c(if_else_exit_lints, unnecessary_brace_lints) + unnecessary_nested_if_expr <- xml_find_all(xml, unnecessary_nested_if_xpath) + unnecessary_nested_if_lints <- xml_nodes_to_lints( + unnecessary_nested_if_expr, + source_expression = source_expression, + lint_message = paste( + "Don't use nested `if` statements, where a single `if` with the combined conditional expression will do.", + "For example, instead of `if (x) { if (y) { ... }}`, use `if (x && y) { ... }`." + ), + type = "warning" + ) + + unnecessary_else_brace_expr <- xml_find_all(xml, unnecessary_else_brace_xpath) + unnecessary_else_brace_lints <- xml_nodes_to_lints( + unnecessary_else_brace_expr, + source_expression = source_expression, + lint_message = "Simplify this condition by using 'else if' instead of 'else { if.", + type = "warning" + ) + + c(if_else_exit_lints, unnecessary_brace_lints, unnecessary_nested_if_lints, unnecessary_else_brace_lints) }) } diff --git a/R/unnecessary_placeholder_linter.R b/R/unnecessary_placeholder_linter.R index cc31cef3c..c032fc591 100644 --- a/R/unnecessary_placeholder_linter.R +++ b/R/unnecessary_placeholder_linter.R @@ -33,7 +33,7 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export unnecessary_placeholder_linter <- function() { - # TODO(michaelchirico): handle R4.2.0 native placeholder _ as well + # NB: Native placeholder '_' must be used with a named argument, so it's not relevant here. xpath <- glue(" //SPECIAL[{ xp_text_in_table(magrittr_pipes) }] /following-sibling::expr[ @@ -51,7 +51,6 @@ unnecessary_placeholder_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) bad_expr <- xml_find_all(xml, xpath) diff --git a/R/unreachable_code_linter.R b/R/unreachable_code_linter.R index 7b8311dc2..124b5a12f 100644 --- a/R/unreachable_code_linter.R +++ b/R/unreachable_code_linter.R @@ -6,6 +6,13 @@ #' is fine for exploration, but shouldn't ultimately be checked in. Comments #' meant for posterity should be placed *before* the final `return()`. #' +#' @param allow_comment_regex Character vector of regular expressions which identify +#' comments to exclude when finding unreachable terminal comments. By default, this +#' includes the default "skip region" end marker for `{covr}` +#' (option "covr.exclude_end", or `"# nocov end"` if unset). +#' The end marker for `{lintr}` (`settings$exclude_end`) is always included. +#' Note that the regexes should include the initial comment character `#`. +#' #' @examples #' # will produce lints #' code_lines <- "f <- function() {\n return(1 + 1)\n 2 + 2\n}" @@ -15,14 +22,21 @@ #' linters = unreachable_code_linter() #' ) #' -#' code_lines <- "f <- if (FALSE) {\n 2 + 2\n}" +#' code_lines <- "if (FALSE) {\n 2 + 2\n}" +#' writeLines(code_lines) +#' lint( +#' text = code_lines, +#' linters = unreachable_code_linter() +#' ) +#' +#' code_lines <- "while (FALSE) {\n 2 + 2\n}" #' writeLines(code_lines) #' lint( #' text = code_lines, #' linters = unreachable_code_linter() #' ) #' -#' code_lines <- "f <- while (FALSE) {\n 2 + 2\n}" +#' code_lines <- "f <- function() {\n return(1)\n # end skip\n}" #' writeLines(code_lines) #' lint( #' text = code_lines, @@ -37,24 +51,31 @@ #' linters = unreachable_code_linter() #' ) #' -#' code_lines <- "f <- if (foo) {\n 2 + 2\n}" +#' code_lines <- "if (foo) {\n 2 + 2\n}" #' writeLines(code_lines) #' lint( #' text = code_lines, #' linters = unreachable_code_linter() #' ) #' -#' code_lines <- "f <- while (foo) {\n 2 + 2\n}" +#' code_lines <- "while (foo) {\n 2 + 2\n}" #' writeLines(code_lines) #' lint( #' text = code_lines, #' linters = unreachable_code_linter() #' ) #' +#' code_lines <- "f <- function() {\n return(1)\n # end skip\n}" +#' writeLines(code_lines) +#' lint( +#' text = code_lines, +#' linters = unreachable_code_linter(allow_comment_regex = "# end skip") +#' ) +#' #' @evalRd rd_tags("unreachable_code_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -unreachable_code_linter <- function() { +unreachable_code_linter <- function(allow_comment_regex = getOption("covr.exclude_end", "# nocov end")) { expr_after_control <- " (//REPEAT | //ELSE | //FOR)/following-sibling::expr[1] | (//IF | //WHILE)/following-sibling::expr[2] @@ -84,9 +105,8 @@ unreachable_code_linter <- function() { ") xpath_if_while <- " - (//WHILE | //IF) - /following-sibling::expr[1][NUM_CONST[text() = 'FALSE']] - /following-sibling::expr[1] + (//WHILE | //IF)[following-sibling::expr[1]/NUM_CONST[text() = 'FALSE']] + /parent::expr " xpath_else <- " @@ -108,32 +128,34 @@ unreachable_code_linter <- function() { expr[vapply(expr, xml2::xml_length, integer(1L)) != 0L] } - # exclude comments that start with a nolint directive - drop_nolint_end_comment <- function(expr) { - is_nolint_end_comment <- xml2::xml_name(expr) == "COMMENT" & - re_matches(xml_text(expr), settings$exclude_end) - expr[!is_nolint_end_comment] + drop_valid_comments <- function(expr, valid_comment_re) { + is_valid_comment <- xml2::xml_name(expr) == "COMMENT" & + re_matches(xml_text(expr), valid_comment_re) + expr[!is_valid_comment] } Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) + + # run here because 'settings$exclude_end' may not be set correctly at "compile time". + # also build with '|', not rex::rex(or(.)), the latter which will double-escape the regex. + allow_comment_regex <- paste(union(allow_comment_regex, settings$exclude_end), collapse = "|") expr_return_stop <- xml_find_all(xml, xpath_return_stop) lints_return_stop <- xml_nodes_to_lints( - drop_nolint_end_comment(expr_return_stop), + drop_valid_comments(expr_return_stop, allow_comment_regex), source_expression = source_expression, - lint_message = "Code and comments coming after a return() or stop() should be removed.", + lint_message = "Remove code and comments coming after return() or stop().", type = "warning" ) expr_next_break <- xml_find_all(xml, xpath_next_break) lints_next_break <- xml_nodes_to_lints( - drop_nolint_end_comment(expr_next_break), + drop_valid_comments(expr_next_break, allow_comment_regex), source_expression = source_expression, - lint_message = "Code and comments coming after a `next` or `break` should be removed.", + lint_message = "Remove code and comments coming after `next` or `break`.", type = "warning" ) @@ -142,7 +164,7 @@ unreachable_code_linter <- function() { lints_if_while <- xml_nodes_to_lints( expr_if_while, source_expression = source_expression, - lint_message = "Code inside a conditional loop with a deterministically false condition should be removed.", + lint_message = "Remove code inside a conditional loop with a deterministically false condition.", type = "warning" ) @@ -151,7 +173,7 @@ unreachable_code_linter <- function() { lints_else <- xml_nodes_to_lints( expr_else, source_expression = source_expression, - lint_message = "Code inside an else block after a deterministically true if condition should be removed.", + lint_message = "Remove code inside an else block after a deterministically true condition.", type = "warning" ) diff --git a/R/unused_import_linter.R b/R/unused_import_linter.R index 707e85626..65c74bea3 100644 --- a/R/unused_import_linter.R +++ b/R/unused_import_linter.R @@ -54,8 +54,7 @@ unused_import_linter <- function(allow_ns_usage = FALSE, } import_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] - /parent::expr + parent::expr /parent::expr[ expr[2][STR_CONST] or not(SYMBOL_SUB[ @@ -65,8 +64,8 @@ unused_import_linter <- function(allow_ns_usage = FALSE, ] " + xp_used_functions <- "self::SYMBOL_FUNCTION_CALL[not(preceding-sibling::NS_GET)]" xp_used_symbols <- paste( - "//SYMBOL_FUNCTION_CALL[not(preceding-sibling::NS_GET)]", "//SYMBOL[not( parent::expr/preceding-sibling::expr[last()]/SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] )]", @@ -76,9 +75,11 @@ unused_import_linter <- function(allow_ns_usage = FALSE, Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content - if (is.null(xml)) return(list()) + library_calls <- source_expression$xml_find_function_calls(c("library", "require")) + all_calls <- source_expression$xml_find_function_calls(NULL) + + import_exprs <- xml_find_all(library_calls, import_xpath) - import_exprs <- xml_find_all(xml, import_xpath) if (length(import_exprs) == 0L) { return(list()) } @@ -87,6 +88,7 @@ unused_import_linter <- function(allow_ns_usage = FALSE, imported_pkgs <- as.character(parse(text = imported_pkgs, keep.source = FALSE)) used_symbols <- unique(c( + xml_text(xml_find_all(all_calls, xp_used_functions)), xml_text(xml_find_all(xml, xp_used_symbols)), extract_glued_symbols(xml, interpret_glue = interpret_glue) )) @@ -107,8 +109,7 @@ unused_import_linter <- function(allow_ns_usage = FALSE, logical(1L) ) - # TODO(michaelchirico): instead of vectorizing over packages, - # xml_find_all SYMBOL_PACKAGE namespaces and check imported_pkgs %in% + # TODO(#2480): Only call //SYMBOL_PACKAGE once. is_ns_used <- vapply( imported_pkgs, function(pkg) { @@ -129,7 +130,7 @@ unused_import_linter <- function(allow_ns_usage = FALSE, lint_message <- ifelse( is_ns_used[is_unused][unused_packages], paste0( - "Package '", unused_packages, "' is only used by namespace. ", + "Don't attach package '", unused_packages, "', which is only used by namespace. ", "Check that it is installed using loadNamespace() instead." ), paste0("Package '", unused_packages, "' is attached but never used.") diff --git a/R/use_lintr.R b/R/use_lintr.R index 829adf3d7..d72711b5e 100644 --- a/R/use_lintr.R +++ b/R/use_lintr.R @@ -8,7 +8,7 @@ #' #' * `tidyverse` creates a minimal lintr config, based on the default linters ([linters_with_defaults()]). #' These are suitable for following [the tidyverse style guide](https://style.tidyverse.org/). -#' * `full` creates a lintr config using all available linters via [linters_with_tags()]. +#' * `full` creates a lintr config using all available linters via [all_linters()]. #' #' @return Path to the generated configuration, invisibly. #' diff --git a/R/utils.R b/R/utils.R index 159d58fdf..8d2f92378 100644 --- a/R/utils.R +++ b/R/utils.R @@ -201,9 +201,9 @@ release_bullets <- function() { } # nocov end -# see issue #923 -- some locales ignore _ when running sort(), others don't. -# we want to consistently treat "_" < "n" = "N" -platform_independent_order <- function(x) order(tolower(gsub("_", "0", x, fixed = TRUE))) +# see issue #923, PR #2455 -- some locales ignore _ when running sort(), others don't. +# We want to consistently treat "_" < "n" = "N"; C locale does this, which 'radix' uses. +platform_independent_order <- function(x) order(tolower(x), method = "radix") platform_independent_sort <- function(x) x[platform_independent_order(x)] #' Extract text from `STR_CONST` nodes @@ -221,20 +221,24 @@ platform_independent_sort <- function(x) x[platform_independent_order(x)] #' and `xpath` is specified, it is extracted with [xml2::xml_find_chr()]. #' @param xpath An XPath, passed on to [xml2::xml_find_chr()] after wrapping with `string()`. #' -#' @examplesIf requireNamespace("withr", quietly = TRUE) -#' tmp <- withr::local_tempfile(lines = "c('a', 'b')") +#' @examples +#' tmp <- tempfile() +#' writeLines("c('a', 'b')", tmp) #' expr_as_xml <- get_source_expressions(tmp)$expressions[[1L]]$xml_parsed_content #' writeLines(as.character(expr_as_xml)) #' get_r_string(expr_as_xml, "expr[2]") # "a" #' get_r_string(expr_as_xml, "expr[3]") # "b" +#' unlink(tmp) #' #' # more importantly, extract strings under R>=4 raw strings #' @examplesIf getRversion() >= "4.0.0" -#' tmp4.0 <- withr::local_tempfile(lines = "c(R'(a\\b)', R'--[a\\\"\'\"\\b]--')") +#' tmp4.0 <- tempfile() +#' writeLines("c(R'(a\\b)', R'--[a\\\"\'\"\\b]--')", tmp4.0) #' expr_as_xml4.0 <- get_source_expressions(tmp4.0)$expressions[[1L]]$xml_parsed_content #' writeLines(as.character(expr_as_xml4.0)) #' get_r_string(expr_as_xml4.0, "expr[2]") # "a\\b" #' get_r_string(expr_as_xml4.0, "expr[3]") # "a\\\"'\"\\b" +#' unlink(tmp4.0) #' #' @export get_r_string <- function(s, xpath = NULL) { diff --git a/R/vector_logic_linter.R b/R/vector_logic_linter.R index de090befa..2705288cc 100644 --- a/R/vector_logic_linter.R +++ b/R/vector_logic_linter.R @@ -31,6 +31,11 @@ #' linters = vector_logic_linter() #' ) #' +#' lint( +#' text = "filter(x, A && B)", +#' linters = vector_logic_linter() +#' ) +#' #' # okay #' lint( #' text = "if (TRUE && FALSE) 1", @@ -42,6 +47,11 @@ #' linters = vector_logic_linter() #' ) #' +#' lint( +#' text = "filter(x, A & B)", +#' linters = vector_logic_linter() +#' ) +#' #' @evalRd rd_tags("vector_logic_linter") #' @seealso #' - [linters] for a complete list of linters available in lintr. @@ -60,7 +70,7 @@ vector_logic_linter <- function() { # ... # # we _don't_ want to match anything on the second expr, hence this - xpath <- " + condition_xpath <- " (//AND | //OR)[ ancestor::expr[ not(preceding-sibling::OP-RIGHT-PAREN) @@ -74,19 +84,46 @@ vector_logic_linter <- function() { preceding-sibling::expr[last()][SYMBOL_FUNCTION_CALL[not(text() = 'expect_true' or text() = 'expect_false')]] or preceding-sibling::OP-LEFT-BRACKET ]) + and not(parent::expr/expr[ + STR_CONST + or expr/SYMBOL_FUNCTION_CALL[text() = 'as.raw' or text() = 'as.octmode' or text() = 'as.hexmode'] + ]) ] " + subset_xpath <- " + parent::expr[not(SYMBOL_PACKAGE[text() = 'stats'])] + /parent::expr + //expr[ + (AND2 or OR2) + and not(preceding-sibling::expr[last()]/SYMBOL_FUNCTION_CALL[not(text() = 'subset' or text() = 'filter')]) + and not(preceding-sibling::OP-LEFT-BRACKET) + and not(preceding-sibling::*[not(self::COMMENT)][2][self::SYMBOL_SUB and text() = 'circular']) + ]/*[2] + " + Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - bad_expr <- xml_find_all(xml, xpath) + xml_call <- source_expression$xml_find_function_calls(c("subset", "filter")) + + condition_expr <- xml_find_all(xml, condition_xpath) + condition_op <- xml_text(condition_expr) + condition_lints <- xml_nodes_to_lints( + condition_expr, + source_expression = source_expression, + lint_message = sprintf("Use `%s` in conditional expressions.", strrep(condition_op, 2L)), + type = "warning" + ) - xml_nodes_to_lints( - bad_expr, + subset_expr <- xml_find_all(xml_call, subset_xpath) + subset_op <- xml_text(subset_expr) + subset_lints <- xml_nodes_to_lints( + subset_expr, source_expression = source_expression, - lint_message = "Conditional expressions require scalar logical operators (&& and ||)", + lint_message = sprintf("Use `%s` in subsetting expressions.", substr(subset_op, 1L, 1L)), type = "warning" ) + + c(condition_lints, subset_lints) }) } diff --git a/R/which_grepl_linter.R b/R/which_grepl_linter.R index 72d250911..747f65a7e 100644 --- a/R/which_grepl_linter.R +++ b/R/which_grepl_linter.R @@ -19,10 +19,10 @@ #' @evalRd rd_tags("which_grepl_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -which_grepl_linter <- make_linter_from_xpath( +which_grepl_linter <- make_linter_from_function_xpath( + function_names = "grepl", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'grepl'] - /parent::expr + parent::expr /parent::expr /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'which']] ", diff --git a/R/with.R b/R/with.R index 399d5769e..8a036c1b4 100644 --- a/R/with.R +++ b/R/with.R @@ -149,10 +149,12 @@ all_linters <- function(..., packages = "lintr") { #' #' @param defaults Default list of linters to modify. Must be named. #' @inheritParams linters_with_tags -#' @examplesIf requireNamespace("withr", quietly = TRUE) +#' @examples #' # When using interactively you will usually pass the result onto `lint` or `lint_package()` -#' f <- withr::local_tempfile(lines = "my_slightly_long_variable_name <- 2.3", fileext = "R") +#' f <- tempfile() +#' writeLines("my_slightly_long_variable_name <- 2.3", f) #' lint(f, linters = linters_with_defaults(line_length_linter = line_length_linter(120L))) +#' unlink(f) #' #' # the default linter list with a different line length cutoff #' my_linters <- linters_with_defaults(line_length_linter = line_length_linter(120L)) diff --git a/R/with_id.R b/R/with_id.R index 3380d432c..c8ae5149a 100644 --- a/R/with_id.R +++ b/R/with_id.R @@ -1,4 +1,3 @@ - #' Extract row by ID #' #' @describeIn ids_with_token diff --git a/R/xp_utils.R b/R/xp_utils.R index 50b35fc98..b96a39f57 100644 --- a/R/xp_utils.R +++ b/R/xp_utils.R @@ -118,9 +118,21 @@ xp_find_location <- function(xml, xpath) { #' way to XPath 2.0-ish support by writing this simple function to remove comments. #' #' @noRd -xpath_comment_re <- rex::rex( +xpath_comment_re <- rex( "(:", zero_or_more(not(":)")), ":)" ) xp_strip_comments <- function(xpath) rex::re_substitutes(xpath, xpath_comment_re, "", global = TRUE) + +#' Combine two or more nodesets to a single nodeset +#' +#' Useful for calling `{xml2}` functions on a combined set of nodes obtained using different XPath searches. +#' +#' @noRd +# TODO(r-lib/xml2#433): remove this and just use c() +combine_nodesets <- function(...) { + res <- c(...) + class(res) <- "xml_nodeset" + res +} diff --git a/R/yoda_test_linter.R b/R/yoda_test_linter.R index 442a77f64..1b4b0c671 100644 --- a/R/yoda_test_linter.R +++ b/R/yoda_test_linter.R @@ -47,26 +47,25 @@ yoda_test_linter <- function() { " pipes <- setdiff(magrittr_pipes, c("%$%", "%<>%")) xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical' or text() = 'expect_setequal'] - /parent::expr - /following-sibling::expr[1][ {const_condition} ] - /parent::expr[not(preceding-sibling::*[self::PIPE or self::SPECIAL[{ xp_text_in_table(pipes) }]])] + parent::expr + /following-sibling::expr[1][ {const_condition} ] + /parent::expr[not(preceding-sibling::*[self::PIPE or self::SPECIAL[{ xp_text_in_table(pipes) }]])] ") second_const_xpath <- glue("expr[position() = 3 and ({const_condition})]") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - if (is.null(xml)) return(list()) - - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- xml_find_all( + source_expression$xml_find_function_calls(c("expect_equal", "expect_identical", "expect_setequal")), + xpath + ) matched_call <- xp_call_name(bad_expr) second_const <- xml_find_first(bad_expr, second_const_xpath) lint_message <- ifelse( is.na(second_const), paste( - "Tests should compare objects in the order 'actual', 'expected', not the reverse.", + "Compare objects in tests in the order 'actual', 'expected', not the reverse.", sprintf("For example, do %1$s(foo(x), 2L) instead of %1$s(2L, foo(x)).", matched_call) ), sprintf("Avoid storing placeholder tests like %s(1, 1)", matched_call) diff --git a/R/zzz.R b/R/zzz.R index fb4f20f96..c8b658510 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -47,53 +47,13 @@ default_linters <- modify_defaults( #' There is a list for the default elements and another that contains all available elements. #' Use [modify_defaults()] to produce a custom list. #' -#' @details -#' The following functions are sometimes regarded as undesirable: -#' -#' * [attach()] modifies the global search path. Use roxygen2's @importFrom statement in packages, or `::` in scripts. -#' * [browser()] pauses execution when run and is likely a leftover from debugging. It should be removed. -#' * [debug()] traps a function and causes execution to pause when that function is run. It should be removed. -#' * [debugcall()] works similarly to [debug()], causing execution to pause. It should be removed. -#' * [debugonce()] is only useful for interactive debugging. It should be removed. -#' * [detach()] modifies the global search path. Detaching environments from the search path is rarely necessary in -#' production code. -#' * [ifelse()] isn't type stable. Use an `if`/`else` block for scalar logic, or use -#' `dplyr::if_else()`/`data.table::fifelse()` for type stable vectorized logic. -#' * [.libPaths()] permanently modifies the library location. Use [withr::with_libpaths()] for a temporary change -#' instead. -#' * [library()] modifies the global search path. Use roxygen2's @importFrom statement in packages, or `::` in scripts. -#' * [loadNamespace()] doesn't provide an easy way to signal failures. Use the return value of [requireNamespace()] -#' instead. -#' * [mapply()] isn't type stable. Use [Map()] to guarantee a list is returned and simplify accordingly. -#' * [options()] permanently modifies the session options. Use [withr::with_options()] for a temporary change instead. -#' * [par()] permanently modifies the graphics device parameters. Use [withr::with_par()] for a temporary change -#' instead. -#' * [require()] modifies the global search path. Use roxygen2's @importFrom statement in packages, and [library()] -#' or `::` in scripts. -#' * [sapply()] isn't type stable. Use [vapply()] with an appropriate `FUN.VALUE=` argument to obtain type stable -#' simplification. -#' * [setwd()] modifies the global working directory. Use [withr::with_dir()] for a temporary change instead. -#' * [sink()] permanently redirects output. Use [withr::with_sink()] for a temporary redirection instead. -#' * [source()] loads code into the global environment unless `local = TRUE` is used, which can cause unexpected -#' behavior. -#' * [substring()] should be replaced by [substr()] with appropriate `stop=` value. -#' * [Sys.setenv()] permanently modifies the global environment variables. Use [withr::with_envvar()] for a temporary -#' change instead. -#' * [Sys.setlocale()] permanently modifies the session locale. Use [withr::with_locale()] for a temporary change -#' instead. -#' * [trace()] traps a function and causes execution of arbitrary code when that function is run. It should be removed. -#' * [undebug()] is only useful for interactive debugging with [debug()]. It should be removed. -#' * [untrace()] is only useful for interactive debugging with [trace()]. It should be removed. -#' -#' The following operators are sometimes regarded as undesirable: -#' -#' * \code{\link[base:ns-dblcolon]{:::}} accesses non-exported functions inside packages. Code relying on these is -#' likely to break in future versions of the package because the functions are not part of the public interface and -#' may be changed or removed by the maintainers without notice. -#' Use public functions via `::` instead. -#' * [`<<-`][base::assignOps] and `->>` assign outside the current environment in a way that can be hard to reason -#' about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment -#' with [assign()]. Recall that you can create an environment at the desired scope with [new.env()]. +#' @evalRd c( +#' "\\details{", +#' rd_undesirable_functions(), +#' "", +#' rd_undesirable_operators(), +#' "}" +#' ) #' #' @format A named list of character strings. #' @rdname default_undesirable_functions @@ -156,7 +116,7 @@ all_undesirable_functions <- modify_defaults( "which can cause hard-to-predict behavior" ), structure = - "Use class<-, names<-, and attr<- to set attributes", + "Use `class<-`, `names<-`, and `attr<-` to set attributes", substring = "use substr() with appropriate `stop=` value.", Sys.setenv = @@ -207,6 +167,28 @@ default_undesirable_functions <- all_undesirable_functions[names(all_undesirable NULL )] +rd_auto_link <- function(x) { + x <- unlist(x) + x <- gsub("([a-zA-Z0-9.]+)::([a-zA-Z0-9._]+)\\(\\)", "\\\\code{\\\\link[\\1:\\2]{\\1::\\2()}}", x) + x <- gsub("([^:a-zA-Z0-9._])([a-zA-Z0-9._]+)\\(\\)", "\\1\\\\code{\\\\link[=\\2]{\\2()}}", x) + x <- gsub("`([^`]+)`", "\\\\code{\\1}", x) + x +} + +rd_undesirable_functions <- function() { + alternatives <- rd_auto_link(default_undesirable_functions) + + c( + "The following functions are sometimes regarded as undesirable:", + "\\itemize{", + sprintf( + "\\item \\code{\\link[=%1$s]{%1$s()}} As an alternative, %2$s.", + names(default_undesirable_functions), alternatives + ), + "}" + ) +} + #' @rdname default_undesirable_functions #' @format NULL #' @export @@ -215,7 +197,7 @@ all_undesirable_operators <- modify_defaults( ":::" = paste( "It accesses non-exported functions inside packages. Code relying on these is likely to break in", "future versions of the package because the functions are not part of the public interface and may be", - "changed or removed by the maintainers without notice. Use public functions via :: instead." + "changed or removed by the maintainers without notice. Use public functions via `::` instead." ), "<<-" = paste( "It assigns outside the current environment in a way that can be hard to reason about.", @@ -241,6 +223,27 @@ default_undesirable_operators <- all_undesirable_operators[names(all_undesirable NULL )] +rd_undesirable_operators <- function() { + op_link_map <- c( + `:::` = "\\link[base:ns-dblcolon]{:::}", + `<<-` = "\\link[base:assignOps]{<<-}", + `->>` = "\\link[base:assignOps]{<<-}" + ) + op <- names(default_undesirable_operators) + + alternatives <- rd_auto_link(default_undesirable_operators) + + c( + "The following operators are sometimes regarded as undesirable:", + "\\itemize{", + sprintf( + "\\item \\code{%1$s}. %2$s", + op_link_map[op], alternatives + ), + "}" + ) +} + #' Default lintr settings #' #' @description diff --git a/inst/lintr/linters.csv b/inst/lintr/linters.csv index effcbb1a3..f6d614775 100644 --- a/inst/lintr/linters.csv +++ b/inst/lintr/linters.csv @@ -31,14 +31,14 @@ expect_s3_class_linter,package_development best_practices pkg_testthat expect_s4_class_linter,package_development best_practices pkg_testthat expect_true_false_linter,package_development best_practices readability pkg_testthat expect_type_linter,package_development best_practices pkg_testthat -extraction_operator_linter,style best_practices +extraction_operator_linter,style best_practices deprecated fixed_regex_linter,best_practices readability efficiency configurable regex for_loop_index_linter,best_practices readability robustness function_argument_linter,style consistency best_practices function_left_parentheses_linter,style readability default function_return_linter,readability best_practices if_not_else_linter,readability consistency configurable -if_switch_linter,best_practices readability consistency efficiency +if_switch_linter,best_practices readability consistency efficiency configurable ifelse_censor_linter,best_practices efficiency implicit_assignment_linter,style best_practices readability configurable implicit_integer_linter,style consistency best_practices configurable @@ -112,13 +112,13 @@ undesirable_function_linter,style efficiency configurable robustness best_practi undesirable_operator_linter,style efficiency configurable robustness best_practices unnecessary_concatenation_linter,style readability efficiency configurable unnecessary_lambda_linter,best_practices efficiency readability configurable -unnecessary_nested_if_linter,readability best_practices -unnecessary_nesting_linter,readability consistency configurable +unnecessary_nested_if_linter,readability best_practices deprecated +unnecessary_nesting_linter,readability consistency configurable best_practices unnecessary_placeholder_linter,readability best_practices unneeded_concatenation_linter,style readability efficiency configurable deprecated -unreachable_code_linter,best_practices readability +unreachable_code_linter,best_practices readability configurable unused_import_linter,best_practices common_mistakes configurable executing -vector_logic_linter,default efficiency best_practices +vector_logic_linter,default efficiency best_practices common_mistakes which_grepl_linter,readability efficiency consistency regex whitespace_linter,style consistency default yoda_test_linter,package_development best_practices readability pkg_testthat diff --git a/man/T_and_F_symbol_linter.Rd b/man/T_and_F_symbol_linter.Rd index a034e31cd..d9cefa4e3 100644 --- a/man/T_and_F_symbol_linter.Rd +++ b/man/T_and_F_symbol_linter.Rd @@ -7,7 +7,8 @@ T_and_F_symbol_linter() } \description{ -Avoid the symbols \code{T} and \code{F}, and use \code{TRUE} and \code{FALSE} instead. +Although they can be synonyms, avoid the symbols \code{T} and \code{F}, and use \code{TRUE} and \code{FALSE}, respectively, instead. +\code{T} and \code{F} are not reserved keywords and can be assigned to any other values. } \examples{ # will produce lints diff --git a/man/best_practices_linters.Rd b/man/best_practices_linters.Rd index 9df79f943..9e55cb99e 100644 --- a/man/best_practices_linters.Rd +++ b/man/best_practices_linters.Rd @@ -32,7 +32,6 @@ The following linters are tagged with 'best_practices': \item{\code{\link{expect_s4_class_linter}}} \item{\code{\link{expect_true_false_linter}}} \item{\code{\link{expect_type_linter}}} -\item{\code{\link{extraction_operator_linter}}} \item{\code{\link{fixed_regex_linter}}} \item{\code{\link{for_loop_index_linter}}} \item{\code{\link{function_argument_linter}}} @@ -70,7 +69,7 @@ The following linters are tagged with 'best_practices': \item{\code{\link{undesirable_function_linter}}} \item{\code{\link{undesirable_operator_linter}}} \item{\code{\link{unnecessary_lambda_linter}}} -\item{\code{\link{unnecessary_nested_if_linter}}} +\item{\code{\link{unnecessary_nesting_linter}}} \item{\code{\link{unnecessary_placeholder_linter}}} \item{\code{\link{unreachable_code_linter}}} \item{\code{\link{unused_import_linter}}} diff --git a/man/commented_code_linter.Rd b/man/commented_code_linter.Rd index 23c7616eb..49f29c057 100644 --- a/man/commented_code_linter.Rd +++ b/man/commented_code_linter.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/comment_linters.R +% Please edit documentation in R/commented_code_linter.R \name{commented_code_linter} \alias{commented_code_linter} \title{Commented code linter} diff --git a/man/common_mistakes_linters.Rd b/man/common_mistakes_linters.Rd index d3578e567..47faf43a1 100644 --- a/man/common_mistakes_linters.Rd +++ b/man/common_mistakes_linters.Rd @@ -22,5 +22,6 @@ The following linters are tagged with 'common_mistakes': \item{\code{\link{redundant_equals_linter}}} \item{\code{\link{sprintf_linter}}} \item{\code{\link{unused_import_linter}}} +\item{\code{\link{vector_logic_linter}}} } } diff --git a/man/condition_call_linter.Rd b/man/condition_call_linter.Rd index 73302b7fe..a3b3ca7eb 100644 --- a/man/condition_call_linter.Rd +++ b/man/condition_call_linter.Rd @@ -10,10 +10,10 @@ condition_call_linter(display_call = FALSE) \item{display_call}{Logical specifying expected behaviour regarding \code{call.} argument in conditions. \itemize{ -\item \code{NA} forces providing \verb{call.=} but ignores its value (this can be used in +\item \code{NA} forces providing \verb{call. =} but ignores its value (this can be used in cases where you expect a mix of \code{call. = FALSE} and \code{call. = TRUE}) -\item lints \code{call. = FALSE} -\item forces \code{call. = FALSE} (lints \code{call. = TRUE} or missing \verb{call.=} value) +\item \code{TRUE} lints \code{call. = FALSE} +\item \code{FALSE} forces \code{call. = FALSE} (lints \code{call. = TRUE} or missing \verb{call. =} value) }} } \description{ diff --git a/man/configurable_linters.Rd b/man/configurable_linters.Rd index 4f22ee1a7..cb1c17a54 100644 --- a/man/configurable_linters.Rd +++ b/man/configurable_linters.Rd @@ -24,6 +24,7 @@ The following linters are tagged with 'configurable': \item{\code{\link{duplicate_argument_linter}}} \item{\code{\link{fixed_regex_linter}}} \item{\code{\link{if_not_else_linter}}} +\item{\code{\link{if_switch_linter}}} \item{\code{\link{implicit_assignment_linter}}} \item{\code{\link{implicit_integer_linter}}} \item{\code{\link{indentation_linter}}} @@ -52,6 +53,7 @@ The following linters are tagged with 'configurable': \item{\code{\link{unnecessary_concatenation_linter}}} \item{\code{\link{unnecessary_lambda_linter}}} \item{\code{\link{unnecessary_nesting_linter}}} +\item{\code{\link{unreachable_code_linter}}} \item{\code{\link{unused_import_linter}}} } } diff --git a/man/default_undesirable_functions.Rd b/man/default_undesirable_functions.Rd index 47ad7a857..d0f517929 100644 --- a/man/default_undesirable_functions.Rd +++ b/man/default_undesirable_functions.Rd @@ -24,54 +24,38 @@ Lists of function names and operators for \code{\link[=undesirable_function_lint There is a list for the default elements and another that contains all available elements. Use \code{\link[=modify_defaults]{modify_defaults()}} to produce a custom list. } +\keyword{datasets} \details{ The following functions are sometimes regarded as undesirable: \itemize{ -\item \code{\link[=attach]{attach()}} modifies the global search path. Use roxygen2's @importFrom statement in packages, or \code{::} in scripts. -\item \code{\link[=browser]{browser()}} pauses execution when run and is likely a leftover from debugging. It should be removed. -\item \code{\link[=debug]{debug()}} traps a function and causes execution to pause when that function is run. It should be removed. -\item \code{\link[=debugcall]{debugcall()}} works similarly to \code{\link[=debug]{debug()}}, causing execution to pause. It should be removed. -\item \code{\link[=debugonce]{debugonce()}} is only useful for interactive debugging. It should be removed. -\item \code{\link[=detach]{detach()}} modifies the global search path. Detaching environments from the search path is rarely necessary in -production code. -\item \code{\link[=ifelse]{ifelse()}} isn't type stable. Use an \code{if}/\verb{else} block for scalar logic, or use -\code{dplyr::if_else()}/\code{data.table::fifelse()} for type stable vectorized logic. -\item \code{\link[=.libPaths]{.libPaths()}} permanently modifies the library location. Use \code{\link[withr:with_libpaths]{withr::with_libpaths()}} for a temporary change -instead. -\item \code{\link[=library]{library()}} modifies the global search path. Use roxygen2's @importFrom statement in packages, or \code{::} in scripts. -\item \code{\link[=loadNamespace]{loadNamespace()}} doesn't provide an easy way to signal failures. Use the return value of \code{\link[=requireNamespace]{requireNamespace()}} -instead. -\item \code{\link[=mapply]{mapply()}} isn't type stable. Use \code{\link[=Map]{Map()}} to guarantee a list is returned and simplify accordingly. -\item \code{\link[=options]{options()}} permanently modifies the session options. Use \code{\link[withr:with_options]{withr::with_options()}} for a temporary change instead. -\item \code{\link[=par]{par()}} permanently modifies the graphics device parameters. Use \code{\link[withr:with_par]{withr::with_par()}} for a temporary change -instead. -\item \code{\link[=require]{require()}} modifies the global search path. Use roxygen2's @importFrom statement in packages, and \code{\link[=library]{library()}} -or \code{::} in scripts. -\item \code{\link[=sapply]{sapply()}} isn't type stable. Use \code{\link[=vapply]{vapply()}} with an appropriate \verb{FUN.VALUE=} argument to obtain type stable -simplification. -\item \code{\link[=setwd]{setwd()}} modifies the global working directory. Use \code{\link[withr:with_dir]{withr::with_dir()}} for a temporary change instead. -\item \code{\link[=sink]{sink()}} permanently redirects output. Use \code{\link[withr:with_sink]{withr::with_sink()}} for a temporary redirection instead. -\item \code{\link[=source]{source()}} loads code into the global environment unless \code{local = TRUE} is used, which can cause unexpected -behavior. -\item \code{\link[=substring]{substring()}} should be replaced by \code{\link[=substr]{substr()}} with appropriate \verb{stop=} value. -\item \code{\link[=Sys.setenv]{Sys.setenv()}} permanently modifies the global environment variables. Use \code{\link[withr:with_envvar]{withr::with_envvar()}} for a temporary -change instead. -\item \code{\link[=Sys.setlocale]{Sys.setlocale()}} permanently modifies the session locale. Use \code{\link[withr:with_locale]{withr::with_locale()}} for a temporary change -instead. -\item \code{\link[=trace]{trace()}} traps a function and causes execution of arbitrary code when that function is run. It should be removed. -\item \code{\link[=undebug]{undebug()}} is only useful for interactive debugging with \code{\link[=debug]{debug()}}. It should be removed. -\item \code{\link[=untrace]{untrace()}} is only useful for interactive debugging with \code{\link[=trace]{trace()}}. It should be removed. +\item \code{\link[=.libPaths]{.libPaths()}} As an alternative, use \code{\link[withr:with_libpaths]{withr::with_libpaths()}} for a temporary change instead of permanently modifying the library location. +\item \code{\link[=attach]{attach()}} As an alternative, use roxygen2's @importFrom statement in packages, or \code{::} in scripts. \code{\link[=attach]{attach()}} modifies the global search path. +\item \code{\link[=browser]{browser()}} As an alternative, remove this likely leftover from debugging. It pauses execution when run. +\item \code{\link[=debug]{debug()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution to pause when that function is run. +\item \code{\link[=debugcall]{debugcall()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution to pause when that function is run. +\item \code{\link[=debugonce]{debugonce()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution to pause when that function is run. +\item \code{\link[=detach]{detach()}} As an alternative, avoid modifying the global search path. Detaching environments from the search path is rarely necessary in production code. +\item \code{\link[=library]{library()}} As an alternative, use roxygen2's @importFrom statement in packages and \code{::} in scripts, instead of modifying the global search path. +\item \code{\link[=mapply]{mapply()}} As an alternative, use \code{\link[=Map]{Map()}} to guarantee a list is returned and simplify accordingly. +\item \code{\link[=options]{options()}} As an alternative, use \code{\link[withr:with_options]{withr::with_options()}} for a temporary change instead of permanently modifying the session options. +\item \code{\link[=par]{par()}} As an alternative, use \code{\link[withr:with_par]{withr::with_par()}} for a temporary change instead of permanently modifying the graphics device parameters. +\item \code{\link[=require]{require()}} As an alternative, use roxygen2's @importFrom statement in packages and \code{\link[=library]{library()}} or \code{::} in scripts, instead of modifying the global search path. +\item \code{\link[=sapply]{sapply()}} As an alternative, use \code{\link[=vapply]{vapply()}} with an appropriate \code{FUN.VALUE=} argument to obtain type-stable simplification. +\item \code{\link[=setwd]{setwd()}} As an alternative, use \code{\link[withr:with_dir]{withr::with_dir()}} for a temporary change instead of modifying the global working directory. +\item \code{\link[=sink]{sink()}} As an alternative, use \code{\link[withr:with_sink]{withr::with_sink()}} for a temporary redirection instead of permanently redirecting output. +\item \code{\link[=source]{source()}} As an alternative, manage dependencies through packages. \code{\link[=source]{source()}} loads code into the global environment unless \code{local = TRUE} is used, which can cause hard-to-predict behavior. +\item \code{\link[=structure]{structure()}} As an alternative, Use \code{class<-}, \code{names<-}, and \code{attr<-} to set attributes. +\item \code{\link[=Sys.setenv]{Sys.setenv()}} As an alternative, use \code{\link[withr:with_envvar]{withr::with_envvar()}} for a temporary change instead of permanently modifying global environment variables. +\item \code{\link[=Sys.setlocale]{Sys.setlocale()}} As an alternative, use \code{\link[withr:with_locale]{withr::with_locale()}} for a temporary change instead of permanently modifying the session locale. +\item \code{\link[=trace]{trace()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution of arbitrary code when that function is run. +\item \code{\link[=undebug]{undebug()}} As an alternative, remove this likely leftover from debugging. It is only useful for interactive debugging with \code{\link[=debug]{debug()}}. +\item \code{\link[=untrace]{untrace()}} As an alternative, remove this likely leftover from debugging. It is only useful for interactive debugging with \code{\link[=trace]{trace()}}. } The following operators are sometimes regarded as undesirable: \itemize{ -\item \code{\link[base:ns-dblcolon]{:::}} accesses non-exported functions inside packages. Code relying on these is -likely to break in future versions of the package because the functions are not part of the public interface and -may be changed or removed by the maintainers without notice. -Use public functions via \code{::} instead. -\item \code{\link[base:assignOps]{<<-}} and \verb{->>} assign outside the current environment in a way that can be hard to reason -about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment -with \code{\link[=assign]{assign()}}. Recall that you can create an environment at the desired scope with \code{\link[=new.env]{new.env()}}. +\item \code{\link[base:assignOps]{<<-}}. It assigns outside the current environment in a way that can be hard to reason about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment with \code{\link[=assign]{assign()}}. Recall that you can create an environment at the desired scope with \code{\link[=new.env]{new.env()}}. +\item \code{\link[base:ns-dblcolon]{:::}}. It accesses non-exported functions inside packages. Code relying on these is likely to break in future versions of the package because the functions are not part of the public interface and may be changed or removed by the maintainers without notice. Use public functions via \code{::} instead. +\item \code{\link[base:assignOps]{<<-}}. It assigns outside the current environment in a way that can be hard to reason about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment with \code{\link[=assign]{assign()}}. Recall that you can create an environment at the desired scope with \code{\link[=new.env]{new.env()}}. } } -\keyword{datasets} diff --git a/man/deprecated_linters.Rd b/man/deprecated_linters.Rd index 08de6c677..df533f2b3 100644 --- a/man/deprecated_linters.Rd +++ b/man/deprecated_linters.Rd @@ -14,8 +14,10 @@ These linters will be excluded from \code{\link[=linters_with_tags]{linters_with The following linters are tagged with 'deprecated': \itemize{ \item{\code{\link{consecutive_stopifnot_linter}}} +\item{\code{\link{extraction_operator_linter}}} \item{\code{\link{no_tab_linter}}} \item{\code{\link{single_quotes_linter}}} +\item{\code{\link{unnecessary_nested_if_linter}}} \item{\code{\link{unneeded_concatenation_linter}}} } } diff --git a/man/expect_lint.Rd b/man/expect_lint.Rd index 2832f9990..8b7a22fc1 100644 --- a/man/expect_lint.Rd +++ b/man/expect_lint.Rd @@ -40,16 +40,16 @@ This is an expectation function to test that the lints produced by \code{lint} s expect_lint("a", NULL, trailing_blank_lines_linter()) # one expected lint -expect_lint("a\n", "superfluous", trailing_blank_lines_linter()) -expect_lint("a\n", list(message = "superfluous", line_number = 2), trailing_blank_lines_linter()) +expect_lint("a\n", "trailing blank", trailing_blank_lines_linter()) +expect_lint("a\n", list(message = "trailing blank", line_number = 2), trailing_blank_lines_linter()) # several expected lints -expect_lint("a\n\n", list("superfluous", "superfluous"), trailing_blank_lines_linter()) +expect_lint("a\n\n", list("trailing blank", "trailing blank"), trailing_blank_lines_linter()) expect_lint( "a\n\n", list( - list(message = "superfluous", line_number = 2), - list(message = "superfluous", line_number = 3) + list(message = "trailing blank", line_number = 2), + list(message = "trailing blank", line_number = 3) ), trailing_blank_lines_linter() ) diff --git a/man/extraction_operator_linter.Rd b/man/extraction_operator_linter.Rd deleted file mode 100644 index 5fade333f..000000000 --- a/man/extraction_operator_linter.Rd +++ /dev/null @@ -1,62 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/extraction_operator_linter.R -\name{extraction_operator_linter} -\alias{extraction_operator_linter} -\title{Extraction operator linter} -\usage{ -extraction_operator_linter() -} -\description{ -Check that the \code{[[} operator is used when extracting a single element from an object, -not \code{[} (subsetting) nor \code{$} (interactive use). -} -\details{ -There are three subsetting operators in R (\code{[[}, \code{[}, and \code{$}) and they interact differently -with different data structures (atomic vector, list, data frame, etc.). - -Here are a few reasons to prefer the \code{[[} operator over \code{[} or \code{$} when you want to extract -an element from a data frame or a list: -\itemize{ -\item Subsetting a list with \code{[} always returns a smaller list, while \code{[[} returns -the list element. -\item Subsetting a named atomic vector with \code{[} returns a named vector, while \code{[[} returns -the vector element. -\item Subsetting a data frame (but not tibble) with \code{[} is type unstable; it can return -a vector or a data frame. \code{[[}, on the other hand, always returns a vector. -\item For a data frame (but not tibble), \code{$} does partial matching (e.g. \code{df$a} will subset -\code{df$abc}), which can be a source of bugs. \code{[[} doesn't do partial matching. -} - -For data frames (and tibbles), irrespective of the size, the \code{[[} operator is slower than \code{$}. -For lists, however, the reverse is true. -} -\examples{ -# will produce lints -lint( - text = 'iris["Species"]', - linters = extraction_operator_linter() -) - -lint( - text = "iris$Species", - linters = extraction_operator_linter() -) - -# okay -lint( - text = 'iris[["Species"]]', - linters = extraction_operator_linter() -) - -} -\references{ -\itemize{ -\item Subsetting \href{https://adv-r.hadley.nz/subsetting.html}{chapter} from \emph{Advanced R} (Wickham, 2019). -} -} -\seealso{ -\link{linters} for a complete list of linters available in lintr. -} -\section{Tags}{ -\link[=best_practices_linters]{best_practices}, \link[=style_linters]{style} -} diff --git a/man/get_r_string.Rd b/man/get_r_string.Rd index 96a3db2bc..05b8c6062 100644 --- a/man/get_r_string.Rd +++ b/man/get_r_string.Rd @@ -23,20 +23,22 @@ NB: this is also properly vectorized on \code{s}, and accepts a variety of input will become \code{NA} outputs, which helps ensure that \code{length(get_r_string(s)) == length(s)}. } \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -tmp <- withr::local_tempfile(lines = "c('a', 'b')") +tmp <- tempfile() +writeLines("c('a', 'b')", tmp) expr_as_xml <- get_source_expressions(tmp)$expressions[[1L]]$xml_parsed_content writeLines(as.character(expr_as_xml)) get_r_string(expr_as_xml, "expr[2]") # "a" get_r_string(expr_as_xml, "expr[3]") # "b" +unlink(tmp) # more importantly, extract strings under R>=4 raw strings -\dontshow{\}) # examplesIf} \dontshow{if (getRversion() >= "4.0.0") (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -tmp4.0 <- withr::local_tempfile(lines = "c(R'(a\\\\b)', R'--[a\\\\\"\'\"\\\\b]--')") +tmp4.0 <- tempfile() +writeLines("c(R'(a\\\\b)', R'--[a\\\\\"\'\"\\\\b]--')", tmp4.0) expr_as_xml4.0 <- get_source_expressions(tmp4.0)$expressions[[1L]]$xml_parsed_content writeLines(as.character(expr_as_xml4.0)) get_r_string(expr_as_xml4.0, "expr[2]") # "a\\b" get_r_string(expr_as_xml4.0, "expr[3]") # "a\\\"'\"\\b" +unlink(tmp4.0) \dontshow{\}) # examplesIf} } diff --git a/man/get_source_expressions.Rd b/man/get_source_expressions.Rd index d7ab406db..f48939d0e 100644 --- a/man/get_source_expressions.Rd +++ b/man/get_source_expressions.Rd @@ -17,32 +17,36 @@ A \code{list} with three components: \describe{ \item{expressions}{a \code{list} of \code{n+1} objects. The first \code{n} elements correspond to each expression in -\code{filename}, and consist of a list of 9 elements: +\code{filename}, and consist of a list of 8 elements: \itemize{ -\item{\code{filename} (\code{character})} -\item{\code{line} (\code{integer}) the line in \code{filename} where this expression begins} -\item{\code{column} (\code{integer}) the column in \code{filename} where this expression begins} +\item{\code{filename} (\code{character}) the name of the file.} +\item{\code{line} (\code{integer}) the line in the file where this expression begins.} +\item{\code{column} (\code{integer}) the column in the file where this expression begins.} \item{\code{lines} (named \code{character}) vector of all lines spanned by this -expression, named with the line number corresponding to \code{filename}} -\item{\code{parsed_content} (\code{data.frame}) as given by \code{\link[utils:getParseData]{utils::getParseData()}} for this expression} -\item{\code{xml_parsed_content} (\code{xml_document}) the XML parse tree of this -expression as given by \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}} -\item{\code{content} (\code{character}) the same as \code{lines} as a single string (not split across lines)} +expression, named with the corresponding line numbers.} +\item{\code{parsed_content} (\code{data.frame}) as given by \code{\link[utils:getParseData]{utils::getParseData()}} for this expression.} +\item{\code{xml_parsed_content} (\code{xml_document}) the XML parse tree of this expression as given by +\code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}.} +\item{\code{content} (\code{character}) the same as \code{lines} as a single string (not split across lines).} +\item{\code{xml_find_function_calls(function_names)} (\code{function}) a function that returns all \code{SYMBOL_FUNCTION_CALL} +XML nodes from \code{xml_parsed_content} with specified function names.} } The final element of \code{expressions} is a list corresponding to the full file -consisting of 6 elements: +consisting of 7 elements: \itemize{ -\item{\code{filename} (\code{character})} -\item{\code{file_lines} (\code{character}) the \code{\link[=readLines]{readLines()}} output for this file} +\item{\code{filename} (\code{character}) the name of this file.} +\item{\code{file_lines} (\code{character}) the \code{\link[=readLines]{readLines()}} output for this file.} \item{\code{content} (\code{character}) for .R files, the same as \code{file_lines}; -for .Rmd or .qmd scripts, this is the extracted R source code (as text)} +for .Rmd or .qmd scripts, this is the extracted R source code (as text).} \item{\code{full_parsed_content} (\code{data.frame}) as given by -\code{\link[utils:getParseData]{utils::getParseData()}} for the full content} +\code{\link[utils:getParseData]{utils::getParseData()}} for the full content.} \item{\code{full_xml_parsed_content} (\code{xml_document}) the XML parse tree of all -expressions as given by \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}} +expressions as given by \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}.} \item{\code{terminal_newline} (\code{logical}) records whether \code{filename} has a terminal -newline (as determined by \code{\link[=readLines]{readLines()}} producing a corresponding warning)} +newline (as determined by \code{\link[=readLines]{readLines()}} producing a corresponding warning).} +\item{\code{xml_find_function_calls(function_names)} (\code{function}) a function that returns all \code{SYMBOL_FUNCTION_CALL} +XML nodes from \code{full_xml_parsed_content} with specified function names.} } } \item{error}{A \code{Lint} object describing any parsing error.} @@ -63,8 +67,8 @@ This setting is found by taking the first valid result from the following locati } } \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1")) +tmp <- tempfile() +writeLines(c("x <- 1", "y <- x + 1"), tmp) get_source_expressions(tmp) -\dontshow{\}) # examplesIf} +unlink(tmp) } diff --git a/man/ids_with_token.Rd b/man/ids_with_token.Rd index af0cc1b11..35d7c5161 100644 --- a/man/ids_with_token.Rd +++ b/man/ids_with_token.Rd @@ -48,10 +48,11 @@ conjunction with \code{ids_with_token} to iterate over rows containing desired t }} \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1")) +tmp <- tempfile() +writeLines(c("x <- 1", "y <- x + 1"), tmp) source_exprs <- get_source_expressions(tmp) ids_with_token(source_exprs$expressions[[1L]], value = "SYMBOL") with_id(source_exprs$expressions[[1L]], 2L) -\dontshow{\}) # examplesIf} +unlink(tmp) + } diff --git a/man/if_switch_linter.Rd b/man/if_switch_linter.Rd index e1254ff79..8a7cd302b 100644 --- a/man/if_switch_linter.Rd +++ b/man/if_switch_linter.Rd @@ -4,7 +4,14 @@ \alias{if_switch_linter} \title{Require usage of switch() over repeated if/else blocks} \usage{ -if_switch_linter() +if_switch_linter(max_branch_lines = 0L, max_branch_expressions = 0L) +} +\arguments{ +\item{max_branch_lines, max_branch_expressions}{Integer, default 0 indicates "no maximum". +If set any \code{if}/\verb{else if}/.../\verb{else} chain where any branch occupies more than +this number of lines (resp. expressions) will not be linted. The conjugate +applies to \code{switch()} statements -- if these parameters are set, any \code{switch()} +statement with any overly-complicated branches will be linted. See examples.} } \description{ \code{\link[=switch]{switch()}} statements in R are used to delegate behavior based @@ -29,6 +36,64 @@ lint( linters = if_switch_linter() ) +code <- paste( + "if (x == 'a') {", + " 1", + "} else if (x == 'b') {", + " 2", + "} else if (x == 'c') {", + " y <- x", + " z <- sqrt(match(y, letters))", + " z", + "}", + sep = "\n" +) +writeLines(code) +lint( + text = code, + linters = if_switch_linter() +) + +code <- paste( + "if (x == 'a') {", + " 1", + "} else if (x == 'b') {", + " 2", + "} else if (x == 'c') {", + " y <- x", + " z <- sqrt(", + " match(y, letters)", + " )", + " z", + "}", + sep = "\n" +) +writeLines(code) +lint( + text = code, + linters = if_switch_linter() +) + +code <- paste( + "switch(x,", + " a = {", + " 1", + " 2", + " 3", + " },", + " b = {", + " 1", + " 2", + " }", + ")", + sep = "\n" +) +writeLines(code) +lint( + text = code, + linters = if_switch_linter(max_branch_lines = 2L) +) + # okay lint( text = "switch(x, a = 1, b = 2, 3)", @@ -41,10 +106,68 @@ lint( linters = if_switch_linter() ) +code <- paste( + "if (x == 'a') {", + " 1", + "} else if (x == 'b') {", + " 2", + "} else if (x == 'c') {", + " y <- x", + " z <- sqrt(match(y, letters))", + " z", + "}", + sep = "\n" +) +writeLines(code) +lint( + text = code, + linters = if_switch_linter(max_branch_lines = 2L) +) + +code <- paste( + "if (x == 'a') {", + " 1", + "} else if (x == 'b') {", + " 2", + "} else if (x == 'c') {", + " y <- x", + " z <- sqrt(", + " match(y, letters)", + " )", + " z", + "}", + sep = "\n" +) +writeLines(code) +lint( + text = code, + linters = if_switch_linter(max_branch_expressions = 2L) +) + +code <- paste( + "switch(x,", + " a = {", + " 1", + " 2", + " 3", + " },", + " b = {", + " 1", + " 2", + " }", + ")", + sep = "\n" +) +writeLines(code) +lint( + text = code, + linters = if_switch_linter(max_branch_lines = 3L) +) + } \seealso{ \link{linters} for a complete list of linters available in lintr. } \section{Tags}{ -\link[=best_practices_linters]{best_practices}, \link[=consistency_linters]{consistency}, \link[=efficiency_linters]{efficiency}, \link[=readability_linters]{readability} +\link[=best_practices_linters]{best_practices}, \link[=configurable_linters]{configurable}, \link[=consistency_linters]{consistency}, \link[=efficiency_linters]{efficiency}, \link[=readability_linters]{readability} } diff --git a/man/is_lint_level.Rd b/man/is_lint_level.Rd index b0e3e0152..101fcf100 100644 --- a/man/is_lint_level.Rd +++ b/man/is_lint_level.Rd @@ -19,12 +19,13 @@ Helper for determining whether the current \code{source_expression} contains all expressions in the current file, or just a single expression. } \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1")) +tmp <- tempfile() +writeLines(c("x <- 1", "y <- x + 1"), tmp) source_exprs <- get_source_expressions(tmp) is_lint_level(source_exprs$expressions[[1L]], level = "expression") is_lint_level(source_exprs$expressions[[1L]], level = "file") is_lint_level(source_exprs$expressions[[3L]], level = "expression") is_lint_level(source_exprs$expressions[[3L]], level = "file") -\dontshow{\}) # examplesIf} +unlink(tmp) + } diff --git a/man/lint.Rd b/man/lint.Rd index 54d1bbe48..a165a9343 100644 --- a/man/lint.Rd +++ b/man/lint.Rd @@ -2,7 +2,6 @@ % Please edit documentation in R/lint.R \name{lint} \alias{lint} -\alias{lint_file} \alias{lint_dir} \alias{lint_package} \title{Lint a file, directory, or package} @@ -90,12 +89,13 @@ Note that if files contain unparseable encoding problems, only the encoding prob unintelligible error messages from other linters. } \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -f <- withr::local_tempfile(lines = "a=1", fileext = "R") +f <- tempfile() +writeLines("a=1", f) lint(f) # linting a file lint("a = 123\n") # linting inline-code lint(text = "a = 123") # linting inline-code -\dontshow{\}) # examplesIf} +unlink(f) + if (FALSE) { lint_dir() diff --git a/man/linters.Rd b/man/linters.Rd index e436c0f05..10c45d374 100644 --- a/man/linters.Rd +++ b/man/linters.Rd @@ -17,21 +17,21 @@ see also \code{\link[=available_tags]{available_tags()}}. \section{Tags}{ The following tags exist: \itemize{ -\item{\link[=best_practices_linters]{best_practices} (64 linters)} -\item{\link[=common_mistakes_linters]{common_mistakes} (10 linters)} -\item{\link[=configurable_linters]{configurable} (41 linters)} +\item{\link[=best_practices_linters]{best_practices} (63 linters)} +\item{\link[=common_mistakes_linters]{common_mistakes} (11 linters)} +\item{\link[=configurable_linters]{configurable} (43 linters)} \item{\link[=consistency_linters]{consistency} (32 linters)} \item{\link[=correctness_linters]{correctness} (7 linters)} \item{\link[=default_linters]{default} (26 linters)} -\item{\link[=deprecated_linters]{deprecated} (4 linters)} +\item{\link[=deprecated_linters]{deprecated} (6 linters)} \item{\link[=efficiency_linters]{efficiency} (32 linters)} \item{\link[=executing_linters]{executing} (6 linters)} \item{\link[=package_development_linters]{package_development} (14 linters)} \item{\link[=pkg_testthat_linters]{pkg_testthat} (12 linters)} -\item{\link[=readability_linters]{readability} (65 linters)} +\item{\link[=readability_linters]{readability} (64 linters)} \item{\link[=regex_linters]{regex} (4 linters)} \item{\link[=robustness_linters]{robustness} (17 linters)} -\item{\link[=style_linters]{style} (41 linters)} +\item{\link[=style_linters]{style} (40 linters)} \item{\link[=tidy_design_linters]{tidy_design} (1 linters)} } } @@ -68,14 +68,13 @@ The following linters exist: \item{\code{\link{expect_s4_class_linter}} (tags: best_practices, package_development, pkg_testthat)} \item{\code{\link{expect_true_false_linter}} (tags: best_practices, package_development, pkg_testthat, readability)} \item{\code{\link{expect_type_linter}} (tags: best_practices, package_development, pkg_testthat)} -\item{\code{\link{extraction_operator_linter}} (tags: best_practices, style)} \item{\code{\link{fixed_regex_linter}} (tags: best_practices, configurable, efficiency, readability, regex)} \item{\code{\link{for_loop_index_linter}} (tags: best_practices, readability, robustness)} \item{\code{\link{function_argument_linter}} (tags: best_practices, consistency, style)} \item{\code{\link{function_left_parentheses_linter}} (tags: default, readability, style)} \item{\code{\link{function_return_linter}} (tags: best_practices, readability)} \item{\code{\link{if_not_else_linter}} (tags: configurable, consistency, readability)} -\item{\code{\link{if_switch_linter}} (tags: best_practices, consistency, efficiency, readability)} +\item{\code{\link{if_switch_linter}} (tags: best_practices, configurable, consistency, efficiency, readability)} \item{\code{\link{ifelse_censor_linter}} (tags: best_practices, efficiency)} \item{\code{\link{implicit_assignment_linter}} (tags: best_practices, configurable, readability, style)} \item{\code{\link{implicit_integer_linter}} (tags: best_practices, configurable, consistency, style)} @@ -144,12 +143,11 @@ The following linters exist: \item{\code{\link{undesirable_operator_linter}} (tags: best_practices, configurable, efficiency, robustness, style)} \item{\code{\link{unnecessary_concatenation_linter}} (tags: configurable, efficiency, readability, style)} \item{\code{\link{unnecessary_lambda_linter}} (tags: best_practices, configurable, efficiency, readability)} -\item{\code{\link{unnecessary_nested_if_linter}} (tags: best_practices, readability)} -\item{\code{\link{unnecessary_nesting_linter}} (tags: configurable, consistency, readability)} +\item{\code{\link{unnecessary_nesting_linter}} (tags: best_practices, configurable, consistency, readability)} \item{\code{\link{unnecessary_placeholder_linter}} (tags: best_practices, readability)} -\item{\code{\link{unreachable_code_linter}} (tags: best_practices, readability)} +\item{\code{\link{unreachable_code_linter}} (tags: best_practices, configurable, readability)} \item{\code{\link{unused_import_linter}} (tags: best_practices, common_mistakes, configurable, executing)} -\item{\code{\link{vector_logic_linter}} (tags: best_practices, default, efficiency)} +\item{\code{\link{vector_logic_linter}} (tags: best_practices, common_mistakes, default, efficiency)} \item{\code{\link{which_grepl_linter}} (tags: consistency, efficiency, readability, regex)} \item{\code{\link{whitespace_linter}} (tags: consistency, default, style)} \item{\code{\link{yoda_test_linter}} (tags: best_practices, package_development, pkg_testthat, readability)} diff --git a/man/linters_with_defaults.Rd b/man/linters_with_defaults.Rd index 183986a67..9cabd02b4 100644 --- a/man/linters_with_defaults.Rd +++ b/man/linters_with_defaults.Rd @@ -19,10 +19,11 @@ The result of this function is meant to be passed to the \code{linters} argument or to be put in your configuration file. } \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # When using interactively you will usually pass the result onto `lint` or `lint_package()` -f <- withr::local_tempfile(lines = "my_slightly_long_variable_name <- 2.3", fileext = "R") +f <- tempfile() +writeLines("my_slightly_long_variable_name <- 2.3", f) lint(f, linters = linters_with_defaults(line_length_linter = line_length_linter(120L))) +unlink(f) # the default linter list with a different line length cutoff my_linters <- linters_with_defaults(line_length_linter = line_length_linter(120L)) @@ -39,7 +40,7 @@ my_linters <- linters_with_defaults( # checking the included linters names(my_linters) -\dontshow{\}) # examplesIf} + } \seealso{ \itemize{ diff --git a/man/lintr-deprecated.Rd b/man/lintr-deprecated.Rd index 73b3f62f5..f7ef42a41 100644 --- a/man/lintr-deprecated.Rd +++ b/man/lintr-deprecated.Rd @@ -10,6 +10,8 @@ \alias{single_quotes_linter} \alias{consecutive_stopifnot_linter} \alias{no_tab_linter} +\alias{extraction_operator_linter} +\alias{unnecessary_nested_if_linter} \alias{with_defaults} \title{Deprecated functions in lintr} \usage{ @@ -29,6 +31,10 @@ consecutive_stopifnot_linter() no_tab_linter() +extraction_operator_linter() + +unnecessary_nested_if_linter() + with_defaults(..., default = default_linters) } \arguments{ diff --git a/man/make_linter_from_xpath.Rd b/man/make_linter_from_xpath.Rd index ec935ef61..a92c69003 100644 --- a/man/make_linter_from_xpath.Rd +++ b/man/make_linter_from_xpath.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/make_linter_from_xpath.R \name{make_linter_from_xpath} \alias{make_linter_from_xpath} +\alias{make_linter_from_function_xpath} \title{Create a linter from an XPath} \usage{ make_linter_from_xpath( @@ -10,9 +11,19 @@ make_linter_from_xpath( type = c("warning", "style", "error"), level = c("expression", "file") ) + +make_linter_from_function_xpath( + function_names, + xpath, + lint_message, + type = c("warning", "style", "error"), + level = c("expression", "file") +) } \arguments{ \item{xpath}{Character string, an XPath identifying R code to lint. +For \code{make_linter_from_function_xpath()}, the XPath is relative to the \code{SYMBOL_FUNCTION_CALL} nodes of the +selected functions. See \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}} and \code{\link[=get_source_expressions]{get_source_expressions()}}.} \item{lint_message}{The message to be included as the \code{message} @@ -24,6 +35,8 @@ the \code{i}-th lint will be given the \code{i}-th message.} \item{level}{Which level of expression is being tested? \code{"expression"} means an individual expression, while \code{"file"} means all expressions in the current file are available.} + +\item{function_names}{Character vector, names of functions whose calls to examine..} } \description{ Create a linter from an XPath diff --git a/man/nrow_subset_linter.Rd b/man/nrow_subset_linter.Rd index 3e2edcb2a..a32627b79 100644 --- a/man/nrow_subset_linter.Rd +++ b/man/nrow_subset_linter.Rd @@ -21,6 +21,16 @@ lint( linters = nrow_subset_linter() ) +lint( + text = "nrow(filter(x, is_treatment))", + linters = nrow_subset_linter() +) + +lint( + text = "x \%>\% filter(x, is_treatment) \%>\% nrow()", + linters = nrow_subset_linter() +) + # okay lint( text = "with(x, sum(is_treatment, na.rm = TRUE))", diff --git a/man/nzchar_linter.Rd b/man/nzchar_linter.Rd index d729bd63d..92fd83b10 100644 --- a/man/nzchar_linter.Rd +++ b/man/nzchar_linter.Rd @@ -14,7 +14,9 @@ constructions like \code{string == ""} or \code{nchar(string) == 0}. \details{ One crucial difference is in the default handling of \code{NA_character_}, i.e., missing strings. \code{nzchar(NA_character_)} is \code{TRUE}, while \code{NA_character_ == ""} -and \code{nchar(NA_character_) == 0} are both \code{NA}. +and \code{nchar(NA_character_) == 0} are both \code{NA}. Therefore, for strict +compatibility, use \code{nzchar(x, keepNA = TRUE)}. If the input is known to be +complete (no missing entries), this argument can be dropped for conciseness. } \examples{ # will produce lints @@ -30,14 +32,12 @@ lint( # okay lint( - text = "x[nchar(x) > 1]", + text = "x[!nzchar(x, keepNA = TRUE)]", linters = nzchar_linter() ) -# nzchar()'s primary benefit is for vector input; -# for guaranteed-scalar cases like if() conditions, comparing to "" is OK. lint( - text = "if (x == '') y", + text = "x[nzchar(x, keepNA = TRUE)]", linters = nzchar_linter() ) diff --git a/man/paste_linter.Rd b/man/paste_linter.Rd index b2041d875..561ce8709 100644 --- a/man/paste_linter.Rd +++ b/man/paste_linter.Rd @@ -28,8 +28,6 @@ when it comes at the beginning or end of the input, to avoid requiring empty inp \description{ The following issues are linted by default by this linter (see arguments for which can be de-activated optionally): -} -\details{ \enumerate{ \item Block usage of \code{\link[=paste]{paste()}} with \code{sep = ""}. \code{\link[=paste0]{paste0()}} is a faster, more concise alternative. \item Block usage of \code{paste()} or \code{paste0()} with \code{collapse = ", "}. \code{\link[=toString]{toString()}} is a direct diff --git a/man/readability_linters.Rd b/man/readability_linters.Rd index ed0c5f868..372d2fd9e 100644 --- a/man/readability_linters.Rd +++ b/man/readability_linters.Rd @@ -71,7 +71,6 @@ The following linters are tagged with 'readability': \item{\code{\link{T_and_F_symbol_linter}}} \item{\code{\link{unnecessary_concatenation_linter}}} \item{\code{\link{unnecessary_lambda_linter}}} -\item{\code{\link{unnecessary_nested_if_linter}}} \item{\code{\link{unnecessary_nesting_linter}}} \item{\code{\link{unnecessary_placeholder_linter}}} \item{\code{\link{unreachable_code_linter}}} diff --git a/man/return_linter.Rd b/man/return_linter.Rd index 4bcbd175e..0e99df289 100644 --- a/man/return_linter.Rd +++ b/man/return_linter.Rd @@ -6,26 +6,34 @@ \usage{ return_linter( return_style = c("implicit", "explicit"), + allow_implicit_else = TRUE, return_functions = NULL, - except = NULL + except = NULL, + except_regex = NULL ) } \arguments{ \item{return_style}{Character string naming the return style. \code{"implicit"}, -the default, enforeces the Tidyverse guide recommendation to leave terminal +the default, enforces the Tidyverse guide recommendation to leave terminal returns implicit. \code{"explicit"} style requires that \code{return()} always be explicitly supplied.} +\item{allow_implicit_else}{Logical, default \code{TRUE}. If \code{FALSE}, functions with a terminal +\code{if} clause must always have an \verb{else} clause, making the \code{NULL} alternative explicit +if necessary. Similarly, functions with terminal \code{\link[=switch]{switch()}} statements must have an +explicit default case.} + \item{return_functions}{Character vector of functions that are accepted as terminal calls when \code{return_style = "explicit"}. These are in addition to exit functions from base that are always allowed: \code{\link[=stop]{stop()}}, \code{\link[=q]{q()}}, \code{\link[=quit]{quit()}}, \code{\link[=invokeRestart]{invokeRestart()}}, \code{tryInvokeRestart()}, \code{\link[=UseMethod]{UseMethod()}}, \code{\link[=NextMethod]{NextMethod()}}, \code{\link[=standardGeneric]{standardGeneric()}}, \code{\link[=callNextMethod]{callNextMethod()}}, \code{\link[=.C]{.C()}}, \code{\link[=.Call]{.Call()}}, \code{\link[=.External]{.External()}}, and \code{\link[=.Fortran]{.Fortran()}}.} -\item{except}{Character vector of functions that are not checked when +\item{except, except_regex}{Character vector of functions that are not checked when \code{return_style = "explicit"}. These are in addition to namespace hook functions that are never checked: \code{.onLoad()}, \code{.onUnload()}, \code{.onAttach()}, \code{.onDetach()}, -\code{.Last.lib()}, \code{.First()} and \code{.Last()}.} +\code{.Last.lib()}, \code{.First()} and \code{.Last()}. \code{except} matches function names exactly, +while \code{except_regex} does exclusion by pattern matching with \code{\link[rex:re_matches]{rex::re_matches()}}.} } \description{ This linter checks functions' \code{\link[=return]{return()}} expressions. @@ -46,6 +54,13 @@ lint( linters = return_linter(return_style = "explicit") ) +code <- "function(x) {\n if (x > 0) 2\n}" +writeLines(code) +lint( + text = code, + linters = return_linter(allow_implicit_else = FALSE) +) + # okay code <- "function(x) {\n x + 1\n}" writeLines(code) @@ -61,6 +76,12 @@ lint( linters = return_linter(return_style = "explicit") ) +code <- "function(x) {\n if (x > 0) 2 else NULL\n}" +writeLines(code) +lint( + text = code, + linters = return_linter(allow_implicit_else = FALSE) +) } \seealso{ diff --git a/man/style_linters.Rd b/man/style_linters.Rd index 9ef22feda..1a7e188c9 100644 --- a/man/style_linters.Rd +++ b/man/style_linters.Rd @@ -19,7 +19,6 @@ The following linters are tagged with 'style': \item{\code{\link{condition_call_linter}}} \item{\code{\link{consecutive_assertion_linter}}} \item{\code{\link{cyclocomp_linter}}} -\item{\code{\link{extraction_operator_linter}}} \item{\code{\link{function_argument_linter}}} \item{\code{\link{function_left_parentheses_linter}}} \item{\code{\link{implicit_assignment_linter}}} diff --git a/man/todo_comment_linter.Rd b/man/todo_comment_linter.Rd index 0dfa16d64..29dde11f9 100644 --- a/man/todo_comment_linter.Rd +++ b/man/todo_comment_linter.Rd @@ -1,13 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/comment_linters.R +% Please edit documentation in R/todo_comment_linter.R \name{todo_comment_linter} \alias{todo_comment_linter} \title{TODO comment linter} \usage{ -todo_comment_linter(todo = c("todo", "fixme")) +todo_comment_linter(todo = c("todo", "fixme"), except_regex = NULL) } \arguments{ -\item{todo}{Vector of strings that identify TODO comments.} +\item{todo}{Vector of case-insensitive strings that identify TODO comments.} + +\item{except_regex}{Vector of case-sensitive regular expressions that identify +\emph{valid} TODO comments.} } \description{ Check that the source contains no TODO comments (case-insensitive). @@ -15,18 +18,18 @@ Check that the source contains no TODO comments (case-insensitive). \examples{ # will produce lints lint( - text = "x + y # TODO", - linters = todo_comment_linter() + text = "x + y # TOODOO", + linters = todo_comment_linter(todo = "toodoo") ) lint( - text = "pi <- 1.0 # FIXME", - linters = todo_comment_linter() + text = "pi <- 1.0 # FIIXMEE", + linters = todo_comment_linter(todo = "fiixmee") ) lint( - text = "x <- TRUE # hack", - linters = todo_comment_linter(todo = c("todo", "fixme", "hack")) + text = "x <- TRUE # TOODOO(#1234): Fix this hack.", + linters = todo_comment_linter() ) # okay @@ -45,6 +48,11 @@ lint( linters = todo_comment_linter() ) +lint( + text = "x <- TRUE # TODO(#1234): Fix this hack.", + linters = todo_comment_linter(except_regex = "TODO\\\\(#[0-9]+\\\\):") +) + } \seealso{ \link{linters} for a complete list of linters available in lintr. diff --git a/man/trailing_blank_lines_linter.Rd b/man/trailing_blank_lines_linter.Rd index 5cad661d2..29d7cc486 100644 --- a/man/trailing_blank_lines_linter.Rd +++ b/man/trailing_blank_lines_linter.Rd @@ -10,23 +10,25 @@ trailing_blank_lines_linter() Check that there are no trailing blank lines in source code. } \examples{ -\dontshow{if (requireNamespace("withr", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # will produce lints -f <- withr::local_tempfile(lines = "x <- 1\n") -readLines(f) +f <- tempfile() +cat("x <- 1\n\n", file = f) +writeLines(readChar(f, file.size(f))) lint( filename = f, linters = trailing_blank_lines_linter() ) +unlink(f) # okay -f <- withr::local_tempfile(lines = "x <- 1") -readLines(f) +cat("x <- 1\n", file = f) +writeLines(readChar(f, file.size(f))) lint( filename = f, linters = trailing_blank_lines_linter() ) -\dontshow{\}) # examplesIf} +unlink(f) + } \seealso{ \link{linters} for a complete list of linters available in lintr. diff --git a/man/unnecessary_nested_if_linter.Rd b/man/unnecessary_nested_if_linter.Rd deleted file mode 100644 index 3b27ee6e4..000000000 --- a/man/unnecessary_nested_if_linter.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/unnecessary_nested_if_linter.R -\name{unnecessary_nested_if_linter} -\alias{unnecessary_nested_if_linter} -\title{Avoid unnecessary nested \code{if} conditional statements} -\usage{ -unnecessary_nested_if_linter() -} -\description{ -Avoid unnecessary nested \code{if} conditional statements -} -\examples{ -# will produce lints -writeLines("if (x) { \n if (y) { \n return(1L) \n } \n}") -lint( - text = "if (x) { \n if (y) { \n return(1L) \n } \n}", - linters = unnecessary_nested_if_linter() -) - -# okay -writeLines("if (x && y) { \n return(1L) \n}") -lint( - text = "if (x && y) { \n return(1L) \n}", - linters = unnecessary_nested_if_linter() -) - -writeLines("if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}") -lint( - text = "if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}", - linters = unnecessary_nested_if_linter() -) - -} -\seealso{ -\link{linters} for a complete list of linters available in lintr. -} -\section{Tags}{ -\link[=best_practices_linters]{best_practices}, \link[=readability_linters]{readability} -} diff --git a/man/unnecessary_nesting_linter.Rd b/man/unnecessary_nesting_linter.Rd index 484097017..0e185446d 100644 --- a/man/unnecessary_nesting_linter.Rd +++ b/man/unnecessary_nesting_linter.Rd @@ -4,7 +4,13 @@ \alias{unnecessary_nesting_linter} \title{Block instances of unnecessary nesting} \usage{ -unnecessary_nesting_linter(allow_assignment = TRUE) +unnecessary_nesting_linter( + allow_assignment = TRUE, + allow_functions = c("switch", "try", "tryCatch", "withCallingHandlers", "quote", + "expression", "bquote", "substitute", "with_parameters_test_that", "reactive", + "observe", "observeEvent", "renderCachedPlot", "renderDataTable", "renderImage", + "renderPlot", "renderPrint", "renderTable", "renderText", "renderUI") +) } \arguments{ \item{allow_assignment}{Logical, default \code{TRUE}, in which case @@ -13,6 +19,13 @@ if \code{FALSE}, all braced expressions with only one child expression are linte The \code{TRUE} case facilitates interaction with \code{\link[=implicit_assignment_linter]{implicit_assignment_linter()}} for certain cases where an implicit assignment is necessary, so a braced assignment is used to further distinguish the assignment. See examples.} + +\item{allow_functions}{Character vector of functions which always allow +one-child braced expressions. \code{testthat::test_that()} is always allowed because +testthat requires a braced expression in its \code{code} argument. The other defaults +similarly compute on expressions in a way which is worth highlighting by +em-bracing them, even if there is only one expression, while \code{\link[=switch]{switch()}} is allowed +for its use as a control flow analogous to \code{if}/\verb{else}.} } \description{ Excessive nesting harms readability. Use helper functions or early returns @@ -41,6 +54,17 @@ lint( linters = unnecessary_nesting_linter(allow_assignment = FALSE) ) +writeLines("if (x) { \n if (y) { \n return(1L) \n } \n}") +lint( + text = "if (x) { \n if (y) { \n return(1L) \n } \n}", + linters = unnecessary_nesting_linter() +) + +lint( + text = "my_quote({x})", + linters = unnecessary_nesting_linter() +) + # okay code <- "if (A) {\n stop('A is bad because a.')\n} else {\n stop('!A is bad too.')\n}" writeLines(code) @@ -63,6 +87,23 @@ lint( linters = unnecessary_nesting_linter() ) +writeLines("if (x && y) { \n return(1L) \n}") +lint( + text = "if (x && y) { \n return(1L) \n}", + linters = unnecessary_nesting_linter() +) + +writeLines("if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}") +lint( + text = "if (x) { \n y <- x + 1L\n if (y) { \n return(1L) \n } \n}", + linters = unnecessary_nesting_linter() +) + +lint( + text = "my_quote({x})", + linters = unnecessary_nesting_linter(allow_functions = "my_quote") +) + } \seealso{ \itemize{ @@ -71,5 +112,5 @@ lint( } } \section{Tags}{ -\link[=configurable_linters]{configurable}, \link[=consistency_linters]{consistency}, \link[=readability_linters]{readability} +\link[=best_practices_linters]{best_practices}, \link[=configurable_linters]{configurable}, \link[=consistency_linters]{consistency}, \link[=readability_linters]{readability} } diff --git a/man/unreachable_code_linter.Rd b/man/unreachable_code_linter.Rd index 4e91e5cf8..d54f2588a 100644 --- a/man/unreachable_code_linter.Rd +++ b/man/unreachable_code_linter.Rd @@ -4,7 +4,17 @@ \alias{unreachable_code_linter} \title{Block unreachable code and comments following return statements} \usage{ -unreachable_code_linter() +unreachable_code_linter( + allow_comment_regex = getOption("covr.exclude_end", "# nocov end") +) +} +\arguments{ +\item{allow_comment_regex}{Character vector of regular expressions which identify +comments to exclude when finding unreachable terminal comments. By default, this +includes the default "skip region" end marker for \code{{covr}} +(option "covr.exclude_end", or \code{"# nocov end"} if unset). +The end marker for \code{{lintr}} (\code{settings$exclude_end}) is always included. +Note that the regexes should include the initial comment character \verb{#}.} } \description{ Code after e.g. a \code{\link[=return]{return()}} or \code{\link[=stop]{stop()}} @@ -22,14 +32,21 @@ lint( linters = unreachable_code_linter() ) -code_lines <- "f <- if (FALSE) {\n 2 + 2\n}" +code_lines <- "if (FALSE) {\n 2 + 2\n}" writeLines(code_lines) lint( text = code_lines, linters = unreachable_code_linter() ) -code_lines <- "f <- while (FALSE) {\n 2 + 2\n}" +code_lines <- "while (FALSE) {\n 2 + 2\n}" +writeLines(code_lines) +lint( + text = code_lines, + linters = unreachable_code_linter() +) + +code_lines <- "f <- function() {\n return(1)\n # end skip\n}" writeLines(code_lines) lint( text = code_lines, @@ -44,24 +61,31 @@ lint( linters = unreachable_code_linter() ) -code_lines <- "f <- if (foo) {\n 2 + 2\n}" +code_lines <- "if (foo) {\n 2 + 2\n}" writeLines(code_lines) lint( text = code_lines, linters = unreachable_code_linter() ) -code_lines <- "f <- while (foo) {\n 2 + 2\n}" +code_lines <- "while (foo) {\n 2 + 2\n}" writeLines(code_lines) lint( text = code_lines, linters = unreachable_code_linter() ) +code_lines <- "f <- function() {\n return(1)\n # end skip\n}" +writeLines(code_lines) +lint( + text = code_lines, + linters = unreachable_code_linter(allow_comment_regex = "# end skip") +) + } \seealso{ \link{linters} for a complete list of linters available in lintr. } \section{Tags}{ -\link[=best_practices_linters]{best_practices}, \link[=readability_linters]{readability} +\link[=best_practices_linters]{best_practices}, \link[=configurable_linters]{configurable}, \link[=readability_linters]{readability} } diff --git a/man/use_lintr.Rd b/man/use_lintr.Rd index 701e1042c..c4cf98b74 100644 --- a/man/use_lintr.Rd +++ b/man/use_lintr.Rd @@ -14,7 +14,7 @@ If the \code{.lintr} file already exists, an error will be thrown.} \itemize{ \item \code{tidyverse} creates a minimal lintr config, based on the default linters (\code{\link[=linters_with_defaults]{linters_with_defaults()}}). These are suitable for following \href{https://style.tidyverse.org/}{the tidyverse style guide}. -\item \code{full} creates a lintr config using all available linters via \code{\link[=linters_with_tags]{linters_with_tags()}}. +\item \code{full} creates a lintr config using all available linters via \code{\link[=all_linters]{all_linters()}}. }} } \value{ diff --git a/man/vector_logic_linter.Rd b/man/vector_logic_linter.Rd index 0ffe3fa9c..fac73cf22 100644 --- a/man/vector_logic_linter.Rd +++ b/man/vector_logic_linter.Rd @@ -39,6 +39,11 @@ lint( linters = vector_logic_linter() ) +lint( + text = "filter(x, A && B)", + linters = vector_logic_linter() +) + # okay lint( text = "if (TRUE && FALSE) 1", @@ -50,6 +55,11 @@ lint( linters = vector_logic_linter() ) +lint( + text = "filter(x, A & B)", + linters = vector_logic_linter() +) + } \seealso{ \itemize{ @@ -58,5 +68,5 @@ lint( } } \section{Tags}{ -\link[=best_practices_linters]{best_practices}, \link[=default_linters]{default}, \link[=efficiency_linters]{efficiency} +\link[=best_practices_linters]{best_practices}, \link[=common_mistakes_linters]{common_mistakes}, \link[=default_linters]{default}, \link[=efficiency_linters]{efficiency} } diff --git a/tests/testthat/_snaps/methods.md b/tests/testthat/_snaps/methods.md new file mode 100644 index 000000000..27f3acf4b --- /dev/null +++ b/tests/testthat/_snaps/methods.md @@ -0,0 +1,108 @@ +# print.lint, print.lints support optional message wrapping : width = 10 + + Code + print(lints, width = width) + Output + :1:1: + warning: + [test_linter] + The + quick + brown + fox + jumps + over + the + lazy + dog. + a + ^ + +--- + + Code + print(lints) + Output + :1:1: + warning: + [test_linter] + The + quick + brown + fox + jumps + over + the + lazy + dog. + a + ^ + +# print.lint, print.lints support optional message wrapping : width = 20 + + Code + print(lints, width = width) + Output + :1:1: + warning: + [test_linter] + The quick brown + fox jumps over + the lazy dog. + a + ^ + +--- + + Code + print(lints) + Output + :1:1: + warning: + [test_linter] + The quick brown + fox jumps over + the lazy dog. + a + ^ + +# print.lint, print.lints support optional message wrapping : width = 40 + + Code + print(lints, width = width) + Output + :1:1: warning: [test_linter] The + quick brown fox jumps over the lazy + dog. + a + ^ + +--- + + Code + print(lints) + Output + :1:1: warning: [test_linter] The + quick brown fox jumps over the lazy + dog. + a + ^ + +# print.lint, print.lints support optional message wrapping : width = 80 + + Code + print(lints, width = width) + Output + :1:1: warning: [test_linter] The quick brown fox jumps over the lazy dog. + a + ^ + +--- + + Code + print(lints) + Output + :1:1: warning: [test_linter] The quick brown fox jumps over the lazy dog. + a + ^ + diff --git a/tests/testthat/test-absolute_path_linter.R b/tests/testthat/test-absolute_path_linter.R index 30f03d4ae..6fc9b0051 100644 --- a/tests/testthat/test-absolute_path_linter.R +++ b/tests/testthat/test-absolute_path_linter.R @@ -185,3 +185,22 @@ test_that("raw strings are handled correctly", { absolute_path_linter(lax = FALSE) ) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Do not use absolute paths.") + + expect_lint( + trim_some("{ + '/' + '/blah/file.txt' + 'abcdefg' + '~' + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 5L) + ), + absolute_path_linter(lax = FALSE) + ) +}) diff --git a/tests/testthat/test-any_duplicated_linter.R b/tests/testthat/test-any_duplicated_linter.R index 5f238c864..22100b1cf 100644 --- a/tests/testthat/test-any_duplicated_linter.R +++ b/tests/testthat/test-any_duplicated_linter.R @@ -10,112 +10,73 @@ test_that("any_duplicated_linter skips allowed usages", { }) test_that("any_duplicated_linter blocks simple disallowed usages", { - expect_lint( - "any(duplicated(x))", - rex::rex("anyDuplicated(x, ...) > 0 is better"), - any_duplicated_linter() - ) - - expect_lint( - "any(duplicated(foo(x)))", - rex::rex("anyDuplicated(x, ...) > 0 is better"), - any_duplicated_linter() - ) + linter <- any_duplicated_linter() + lint_msg <- rex::rex("anyDuplicated(x, ...) > 0 is better") + expect_lint("any(duplicated(x))", lint_msg, linter) + expect_lint("any(duplicated(foo(x)))", lint_msg, linter) # na.rm doesn't really matter for this since duplicated can't return NA - expect_lint( - "any(duplicated(x), na.rm = TRUE)", - rex::rex("anyDuplicated(x, ...) > 0 is better"), - any_duplicated_linter() - ) - + expect_lint("any(duplicated(x), na.rm = TRUE)", lint_msg, linter) # also catch nested usage - expect_lint( - "foo(any(duplicated(x)))", - rex::rex("anyDuplicated(x, ...) > 0 is better"), - any_duplicated_linter() - ) + expect_lint("foo(any(duplicated(x)))", lint_msg, linter) }) test_that("any_duplicated_linter catches length(unique()) equivalencies too", { + linter <- any_duplicated_linter() + lint_msg_x <- rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)") + lint_msg_df <- rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)") + # non-matches ## different variable - expect_lint("length(unique(x)) == length(y)", NULL, any_duplicated_linter()) + expect_lint("length(unique(x)) == length(y)", NULL, linter) ## different table - expect_lint("length(unique(DF$x)) == nrow(DT)", NULL, any_duplicated_linter()) - expect_lint("length(unique(l1$DF$x)) == nrow(l2$DF)", NULL, any_duplicated_linter()) + expect_lint("length(unique(DF$x)) == nrow(DT)", NULL, linter) + expect_lint("length(unique(l1$DF$x)) == nrow(l2$DF)", NULL, linter) # lintable usage - expect_lint( - "length(unique(x)) == length(x)", - rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), - any_duplicated_linter() - ) + expect_lint("length(unique(x)) == length(x)", lint_msg_x, linter) # argument order doesn't matter - expect_lint( - "length(x) == length(unique(x))", - rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), - any_duplicated_linter() - ) + expect_lint("length(x) == length(unique(x))", lint_msg_x, linter) # nrow-style equivalency - expect_lint( - "nrow(DF) == length(unique(DF$col))", - rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)"), - any_duplicated_linter() - ) - expect_lint( - "nrow(DF) == length(unique(DF[['col']]))", - rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)"), - any_duplicated_linter() - ) + expect_lint("nrow(DF) == length(unique(DF$col))", lint_msg_df, linter) + expect_lint("nrow(DF) == length(unique(DF[['col']]))", lint_msg_df, linter) # match with nesting too - expect_lint( - "nrow(l$DF) == length(unique(l$DF[['col']]))", - rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)"), - any_duplicated_linter() - ) + expect_lint("nrow(l$DF) == length(unique(l$DF[['col']]))", lint_msg_df, linter) # !=, <, and > usages are all alternative ways of writing a test for dupes # technically, the direction of > / < matter, but writing # length(unique(x)) > length(x) doesn't seem like it would ever happen. - expect_lint( - "length(unique(x)) != length(x)", - rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), - any_duplicated_linter() - ) - expect_lint( - "length(unique(x)) < length(x)", - rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), - any_duplicated_linter() - ) - expect_lint( - "length(x) > length(unique(x))", - rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), - any_duplicated_linter() - ) - - # TODO(michaelchirico): try and match data.table- and dplyr-specific versions of - # this, e.g. DT[, length(unique(col)) == .N] or - # > DT %>% filter(length(unique(col)) == n()) + expect_lint("length(unique(x)) != length(x)", lint_msg_x, linter) + expect_lint("length(unique(x)) < length(x)", lint_msg_x, linter) + expect_lint("length(x) > length(unique(x))", lint_msg_x, linter) }) test_that("any_duplicated_linter catches expression with two types of lint", { + linter <- any_duplicated_linter() + lint_msg <- rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)") + expect_lint( - "table(any(duplicated(x)), length(unique(DF$col)) == nrow(DF))", + trim_some("{ + any(duplicated(x)) + length(unique(DF$col)) == nrow(DF) + }"), list( - rex::rex("anyDuplicated(x, ...) > 0 is better"), - rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)") + list(rex::rex("anyDuplicated(x, ...) > 0 is better"), line_number = 2L), + list(lint_msg, line_number = 3L) ), - any_duplicated_linter() + linter ) # ditto for different messages within the length(unique()) tests expect_lint( - "table(length(unique(x)) == length(x), length(unique(DF$col)) == nrow(DF))", + trim_some("{ + length(unique(x)) == length(x) + length(unique(DF$col)) == nrow(DF) + }"), list( - rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), - rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)") + list(rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), line_number = 2L), + list(lint_msg, line_number = 3L) ), - any_duplicated_linter() + linter ) }) diff --git a/tests/testthat/test-any_is_na_linter.R b/tests/testthat/test-any_is_na_linter.R index 43c106b67..398ca53cc 100644 --- a/tests/testthat/test-any_is_na_linter.R +++ b/tests/testthat/test-any_is_na_linter.R @@ -15,14 +15,43 @@ test_that("any_is_na_linter skips allowed usages", { }) test_that("any_is_na_linter blocks simple disallowed usages", { + linter <- any_is_na_linter() lint_message <- rex::rex("anyNA(x) is better than any(is.na(x)).") - expect_lint("any(is.na(x))", lint_message, any_is_na_linter()) - - expect_lint("any(is.na(foo(x)))", lint_message, any_is_na_linter()) + expect_lint("any(is.na(x))", lint_message, linter) + expect_lint("any(is.na(foo(x)))", lint_message, linter) # na.rm doesn't really matter for this since is.na can't return NA - expect_lint("any(is.na(x), na.rm = TRUE)", lint_message, any_is_na_linter()) - + expect_lint("any(is.na(x), na.rm = TRUE)", lint_message, linter) # also catch nested usage - expect_lint("foo(any(is.na(x)))", lint_message, any_is_na_linter()) + expect_lint("foo(any(is.na(x)))", lint_message, linter) +}) + +test_that("NA %in% x is also found", { + linter <- any_is_na_linter() + lint_message <- rex::rex("anyNA(x) is better than NA %in% x.") + + expect_lint("NA %in% x", lint_message, linter) + expect_lint("NA_real_ %in% x", lint_message, linter) + expect_lint("NA_not_a_sentinel_ %in% x", NULL, linter) +}) + +test_that("lints vectorize", { + any_message <- rex::rex("any(is.na(x))") + in_message <- rex::rex("NA %in% x") + + expect_lint( + trim_some("{ + any(is.na(foo(x))) + any(is.na(y), na.rm = TRUE) + NA %in% a + NA_complex_ %in% b + }"), + list( + list(any_message, line_number = 2L), + list(any_message, line_number = 3L), + list(in_message, line_number = 4L), + list(in_message, line_number = 5L) + ), + any_is_na_linter() + ) }) diff --git a/tests/testthat/test-assignment_linter.R b/tests/testthat/test-assignment_linter.R index f46067348..bae8a048e 100644 --- a/tests/testthat/test-assignment_linter.R +++ b/tests/testthat/test-assignment_linter.R @@ -27,14 +27,17 @@ test_that("assignment_linter blocks disallowed usages", { }) test_that("arguments handle <<- and ->/->> correctly", { - expect_lint("1 -> blah", rex::rex("Use <-, not ->, for assignment."), assignment_linter()) - expect_lint("1 ->> blah", rex::rex("->> can have hard-to-predict behavior;"), assignment_linter()) + linter <- assignment_linter() + lint_msg_right <- rex::rex("Replace ->> by assigning to a specific environment") + + expect_lint("1 -> blah", rex::rex("Use <-, not ->, for assignment."), linter) + expect_lint("1 ->> blah", lint_msg_right, linter) # <<- is only blocked optionally - expect_lint("1 <<- blah", NULL, assignment_linter()) + expect_lint("1 <<- blah", NULL, linter) expect_lint( "1 <<- blah", - rex::rex("<<- can have hard-to-predict behavior;"), + rex::rex("Replace <<- by assigning to a specific environment"), assignment_linter(allow_cascading_assign = FALSE) ) @@ -44,7 +47,7 @@ test_that("arguments handle <<- and ->/->> correctly", { # blocked under cascading assign but not under right assign --> blocked expect_lint( "1 ->> blah", - rex::rex("->> can have hard-to-predict behavior;"), + lint_msg_right, assignment_linter(allow_cascading_assign = FALSE, allow_right_assign = TRUE) ) }) @@ -66,7 +69,7 @@ test_that("arguments handle trailing assignment operators correctly", { ) expect_lint( "x <<-\ny", - rex::rex("<<- can have hard-to-predict behavior"), + rex::rex("Replace <<- by assigning to a specific environment"), assignment_linter(allow_trailing = FALSE, allow_cascading_assign = FALSE) ) @@ -174,12 +177,17 @@ test_that("%<>% throws a lint", { test_that("multiple lints throw correct messages", { expect_lint( - "{ x <<- 1; y ->> 2; z -> 3; x %<>% as.character() }", + trim_some("{ + x <<- 1 + y ->> 2 + z -> 3 + x %<>% as.character() + }"), list( - list(message = "<<- can have hard-to-predict behavior"), - list(message = "->> can have hard-to-predict behavior"), - list(message = "Use <-, not ->"), - list(message = "Avoid the assignment pipe %<>%") + list(message = "Replace <<- by assigning to a specific environment", line_number = 2L), + list(message = "Replace ->> by assigning to a specific environment", line_number = 3L), + list(message = "Use <-, not ->", line_number = 4L), + list(message = "Avoid the assignment pipe %<>%", line_number = 5L) ), assignment_linter(allow_cascading_assign = FALSE) ) diff --git a/tests/testthat/test-backport_linter.R b/tests/testthat/test-backport_linter.R index 57de94c7e..0ecb9902a 100644 --- a/tests/testthat/test-backport_linter.R +++ b/tests/testthat/test-backport_linter.R @@ -25,10 +25,14 @@ test_that("backport_linter detects backwards-incompatibility", { ) expect_lint( - "trimws(...names())", + trim_some(" + trimws( + ...names() + ) + "), list( - rex::rex("trimws (R 3.2.0) is not available for dependency R >= 3.0.0."), - rex::rex("...names (R 4.1.0) is not available for dependency R >= 3.0.0.") + list(rex::rex("trimws (R 3.2.0) is not available for dependency R >= 3.0.0."), line_number = 1L), + list(rex::rex("...names (R 4.1.0) is not available for dependency R >= 3.0.0."), line_number = 2L) ), backport_linter("3.0.0") ) diff --git a/tests/testthat/test-boolean_arithmetic_linter.R b/tests/testthat/test-boolean_arithmetic_linter.R index cbeb1c291..163afb73d 100644 --- a/tests/testthat/test-boolean_arithmetic_linter.R +++ b/tests/testthat/test-boolean_arithmetic_linter.R @@ -25,3 +25,19 @@ test_that("boolean_arithmetic_linter requires use of any() or !any()", { expect_lint("sum(x == y) != 0", lint_msg, linter) expect_lint("sum(grepl(pattern, x)) > 0L", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Use any() to express logical aggregations.") + + expect_lint( + trim_some("{ + length(which(x == y)) > 0L + sum(x == y) != 0 + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + boolean_arithmetic_linter() + ) +}) diff --git a/tests/testthat/test-brace_linter.R b/tests/testthat/test-brace_linter.R index e3adc1a59..3727e4c96 100644 --- a/tests/testthat/test-brace_linter.R +++ b/tests/testthat/test-brace_linter.R @@ -315,7 +315,7 @@ test_that("brace_linter lints function expressions correctly", { ") expect_lint( lines, - rex::rex("Any function spanning multiple lines should use curly braces."), + rex::rex("Use curly braces for any function spanning multiple lines."), linter ) }) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 71bf9e6b6..6b0c47aa1 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -34,10 +34,10 @@ fhash <- function(filename) { # `clear_cache` test_that("clear_cache deletes the file if a file is given", { - skip_if_not_installed("mockery") - - mockery::stub(clear_cache, "read_settings", function(...) invisible(...)) - mockery::stub(clear_cache, "unlink", function(...) list(...)) + local_mocked_bindings( + read_settings = function(...) invisible(...), + unlink = function(...) list(...) + ) e1 <- new.env(parent = emptyenv()) d1 <- withr::local_tempfile(pattern = "lintr_cache_") @@ -50,10 +50,10 @@ test_that("clear_cache deletes the file if a file is given", { }) test_that("clear_cache deletes the directory if no file is given", { - skip_if_not_installed("mockery") - - mockery::stub(clear_cache, "read_settings", function(...) invisible(...)) - mockery::stub(clear_cache, "unlink", function(...) list(...)) + local_mocked_bindings( + read_settings = function(...) invisible(...), + unlink = function(...) list(...) + ) expect_identical(clear_cache(file = NULL, path = "."), list(".", recursive = TRUE)) }) @@ -421,10 +421,9 @@ test_that("lint with cache uses the provided relative cache directory", { }) test_that("it works outside of a package", { - skip_if_not_installed("mockery") linter <- assignment_linter() - mockery::stub(lintr:::find_default_encoding, "find_package", function(...) NULL) + local_mocked_bindings(find_package = function(...) NULL) path <- withr::local_tempfile(pattern = "my_cache_dir_") expect_false(dir.exists(path)) expect_lint("a <- 1", NULL, linter, cache = path) diff --git a/tests/testthat/test-ci.R b/tests/testthat/test-ci.R index 6da47a84f..df42f8cd6 100644 --- a/tests/testthat/test-ci.R +++ b/tests/testthat/test-ci.R @@ -27,8 +27,6 @@ test_that("GitHub Actions functionality works in a subdirectory", { }) test_that("GitHub Actions - linting on error works", { - skip_if_not_installed("mockery") - # imitate being on GHA whether or not we are withr::local_envvar(list(GITHUB_ACTIONS = "true", LINTR_ERROR_ON_LINT = "true")) withr::local_options(lintr.rstudio_source_markers = FALSE) @@ -36,32 +34,6 @@ test_that("GitHub Actions - linting on error works", { l <- lint(tmp) - mockery::stub(print.lints, "base::quit", function(...) cat("Tried to quit.\n")) + local_mocked_bindings(quit = function(...) cat("Tried to quit.\n")) expect_output(print(l), "::warning file", fixed = TRUE) }) - -test_that("Printing works for Travis", { - skip_if_not_installed("mockery") - - withr::local_envvar(list(GITHUB_ACTIONS = "false", TRAVIS_REPO_SLUG = "test/repo", LINTR_COMMENT_BOT = "true")) - withr::local_options(lintr.rstudio_source_markers = FALSE) - tmp <- withr::local_tempfile(lines = "x <- 1:nrow(y)") - - l <- lint(tmp) - - mockery::stub(print.lints, "github_comment", function(x, ...) cat(x, "\n")) - expect_output(print(l), "*warning:*", fixed = TRUE) -}) - -test_that("Printing works for Wercker", { - skip_if_not_installed("mockery") - - withr::local_envvar(list(GITHUB_ACTIONS = "false", WERCKER_GIT_BRANCH = "test/repo", LINTR_COMMENT_BOT = "true")) - withr::local_options(lintr.rstudio_source_markers = FALSE) - tmp <- withr::local_tempfile(lines = "x <- 1:nrow(y)") - - l <- lint(tmp) - - mockery::stub(print.lints, "github_comment", function(x, ...) cat(x, "\n")) - expect_output(print(l), "*warning:*", fixed = TRUE) -}) diff --git a/tests/testthat/test-class_equals_linter.R b/tests/testthat/test-class_equals_linter.R index d85c58008..fb640e448 100644 --- a/tests/testthat/test-class_equals_linter.R +++ b/tests/testthat/test-class_equals_linter.R @@ -11,7 +11,7 @@ test_that("class_equals_linter skips allowed usages", { test_that("class_equals_linter blocks simple disallowed usages", { linter <- class_equals_linter() - lint_msg <- rex::rex("Instead of comparing class(x) with ==") + lint_msg <- rex::rex("Use inherits(x, 'class-name'), is. or is(x, 'class')") expect_lint("if (class(x) == 'character') stop('no')", lint_msg, linter) expect_lint("is_regression <- class(x) == 'lm'", lint_msg, linter) @@ -20,7 +20,7 @@ test_that("class_equals_linter blocks simple disallowed usages", { test_that("class_equals_linter blocks usage of %in% for checking class", { linter <- class_equals_linter() - lint_msg <- rex::rex("Instead of comparing class(x) with %in%") + lint_msg <- rex::rex("Use inherits(x, 'class-name'), is. or is(x, 'class')") expect_lint("if ('character' %in% class(x)) stop('no')", lint_msg, linter) expect_lint("if (class(x) %in% 'character') stop('no')", lint_msg, linter) @@ -29,7 +29,7 @@ test_that("class_equals_linter blocks usage of %in% for checking class", { test_that("class_equals_linter blocks class(x) != 'klass'", { expect_lint( "if (class(x) != 'character') TRUE", - rex::rex("Instead of comparing class(x) with !="), + rex::rex("Use inherits(x, 'class-name'), is. or is(x, 'class')"), class_equals_linter() ) }) @@ -43,7 +43,23 @@ test_that("class_equals_linter skips usage for subsetting", { # but not further nesting expect_lint( "x[if (class(x) == 'foo') 1 else 2]", - rex::rex("Instead of comparing class(x) with =="), + rex::rex("Use inherits(x, 'class-name'), is. or is(x, 'class')"), linter ) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Use inherits(x, 'class-name'), is. or is(x, 'class')") + + expect_lint( + trim_some("{ + 'character' %in% class(x) + class(x) == 'character' + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + class_equals_linter() + ) +}) diff --git a/tests/testthat/test-commas_linter.R b/tests/testthat/test-commas_linter.R index eaceb651f..fb8a4e4f3 100644 --- a/tests/testthat/test-commas_linter.R +++ b/tests/testthat/test-commas_linter.R @@ -1,7 +1,7 @@ test_that("returns the correct linting (with default parameters)", { linter <- commas_linter() - msg_after <- rex::rex("Commas should always have a space after.") - msg_before <- rex::rex("Commas should never have a space before.") + msg_after <- rex::rex("Put a space after a comma.") + msg_before <- rex::rex("Remove spaces before a comma.") expect_lint("blah", NULL, linter) expect_lint("fun(1, 1)", NULL, linter) @@ -19,8 +19,8 @@ test_that("returns the correct linting (with default parameters)", { expect_lint( "fun(1 ,1)", list( - msg_before, - msg_after + list(msg_before, column_number = 6L), + list(msg_after, column_number = 8L) ), linter ) @@ -39,6 +39,18 @@ test_that("returns the correct linting (with default parameters)", { expect_lint("switch(op , x = foo, y = bar)", msg_before, linter) expect_lint("switch(op, x = foo, y = bar(a = 4 , b = 5))", msg_before, linter) expect_lint("fun(op, x = foo , y = switch(bar, a = 4, b = 5))", msg_before, linter) + expect_lint( + trim_some(" + switch(op , + x = foo,y = bar + ) + "), + list( + list(msg_before, line_number = 1L), + list(msg_after, line_number = 2L) + ), + linter + ) expect_lint( "fun(op ,bar)", @@ -52,8 +64,8 @@ test_that("returns the correct linting (with default parameters)", { test_that("returns the correct linting (with 'allow_trailing' set)", { linter <- commas_linter(allow_trailing = TRUE) - msg_after <- rex::rex("Commas should always have a space after.") - msg_before <- rex::rex("Commas should never have a space before.") + msg_after <- rex::rex("Put a space after a comma.") + msg_before <- rex::rex("Remove spaces before a comma.") expect_lint("blah", NULL, linter) expect_lint("fun(1, 1)", NULL, linter) diff --git a/tests/testthat/test-commented_code_linter.R b/tests/testthat/test-commented_code_linter.R index 0d034e819..fadc98d5e 100644 --- a/tests/testthat/test-commented_code_linter.R +++ b/tests/testthat/test-commented_code_linter.R @@ -3,9 +3,8 @@ test_that("commented_code_linter skips allowed usages", { expect_lint("blah", NULL, linter) expect_lint("#' blah <- 1", NULL, linter) - expect_lint(c("a <- 1", "# comment without code"), NULL, linter) - expect_lint(c("a <- 1", "# comment without code"), NULL, linter) - expect_lint(c("a <- 1", "## whatever"), NULL, linter) + expect_lint("a <- 1\n# comment without code", NULL, linter) + expect_lint("a <- 1\n## whatever", NULL, linter) expect_lint("TRUE", NULL, linter) expect_lint("#' @examples", NULL, linter) @@ -20,7 +19,7 @@ test_that("commented_code_linter skips allowed usages", { }) test_that("commented_code_linter blocks disallowed usages", { - lint_msg <- rex::rex("Commented code should be removed.") + lint_msg <- rex::rex("Remove commented code.") linter <- commented_code_linter() expect_lint("# blah <- 1", lint_msg, linter) @@ -80,7 +79,7 @@ test_that("commented_code_linter blocks disallowed usages", { test_that("commented_code_linter can detect operators in comments and lint correctly", { linter <- commented_code_linter() - lint_msg <- rex::rex("Commented code should be removed.") + lint_msg <- rex::rex("Remove commented code.") test_ops <- c( "+", "=", "==", "!=", "<=", ">=", "<-", "<<-", "<", ">", "->", @@ -100,7 +99,7 @@ test_that("commented_code_linter can detect operators in comments and lint corre expect_lint( "# 1:3 |> sum()", - rex::rex("Commented code should be removed."), + rex::rex("Remove commented code."), commented_code_linter() ) }) diff --git a/tests/testthat/test-comments.R b/tests/testthat/test-comments.R deleted file mode 100644 index 50356dd98..000000000 --- a/tests/testthat/test-comments.R +++ /dev/null @@ -1,81 +0,0 @@ -clear_ci_info <- function() { - withr::local_envvar( - c( - JENKINS_URL = NA_character_, - GIT_URL = NA_character_, - GIT_URL_1 = NA_character_, - CHANGE_ID = NA_character_, - GIT_COMMIT = NA_character_ - ), - .local_envir = parent.frame() - ) -} - -test_that("it detects CI environments", { - clear_ci_info() - withr::with_envvar( - c(TRAVIS_REPO_SLUG = "foo/bar"), - expect_true(lintr:::in_ci()) - ) - withr::with_envvar( - c(TRAVIS_REPO_SLUG = ""), - expect_false(lintr:::in_ci()) - ) -}) - -test_that("it returns NULL if GIT_URL is not on github", { - clear_ci_info() - withr::local_envvar(c( - JENKINS_URL = "https://jenkins.example.org/", - GIT_URL = "https://example.com/user/repo.git", - CHANGE_ID = "123" - )) - expect_false(lintr:::in_ci()) -}) - - -test_that("it returns NULL for Jenkins PR build info when git URL is missing", { - clear_ci_info() - expect_null(lintr:::jenkins_build_info()) -}) - -test_that("it determines Jenkins PR build info", { - clear_ci_info() - withr::with_envvar( - c( - JENKINS_URL = "https://jenkins.example.org/", - GIT_URL = "https://github.com/user/repo.git", - CHANGE_ID = "123" - ), - { - expect_true(lintr:::in_ci()) - - expect_identical( - lintr:::ci_build_info(), - list(user = "user", repo = "repo", pull = "123", commit = NULL) - ) - } - ) - - withr::with_envvar( - list(JENKINS_URL = NULL, GIT_URL = NULL, CHANGE_ID = NULL), - expect_false(lintr:::in_ci()) - ) -}) - -test_that("it determines Jenkins commit build info", { - clear_ci_info() - withr::local_envvar(c( - JENKINS_URL = "https://jenkins.example.org/", - GIT_URL_1 = "https://github.com/user/repo.git", - GIT_COMMIT = "abcde" - )) - - expect_true(lintr:::in_ci()) - expect_identical(lintr:::ci_build_info(), list( - user = "user", - repo = "repo", - pull = NULL, - commit = "abcde" - )) -}) diff --git a/tests/testthat/test-condition_call_linter.R b/tests/testthat/test-condition_call_linter.R index 6ef37aa0c..46df1def0 100644 --- a/tests/testthat/test-condition_call_linter.R +++ b/tests/testthat/test-condition_call_linter.R @@ -20,13 +20,13 @@ patrick::with_parameters_test_that( "condition_call_linter blocks disallowed usages", { linter <- condition_call_linter() - lint_message <- rex::rex(call_name, anything, "to not display call") + lint_message <- rex::rex(call_name, anything, "not to display the call") expect_lint(paste0(call_name, "('test')"), lint_message, linter) expect_lint(paste0(call_name, "('test', call. = TRUE)"), lint_message, linter) linter <- condition_call_linter(display_call = TRUE) - lint_message <- rex::rex(call_name, anything, "to display call") + lint_message <- rex::rex(call_name, anything, "to display the call") expect_lint(paste0(call_name, "('test', call. = FALSE)"), lint_message, linter) @@ -37,3 +37,17 @@ patrick::with_parameters_test_that( }, call_name = c("stop", "warning") ) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + stop(e) + warning(w) + }"), + list( + list("stop", line_number = 2L), + list("warning", line_number = 3L) + ), + condition_call_linter() + ) +}) diff --git a/tests/testthat/test-condition_message_linter.R b/tests/testthat/test-condition_message_linter.R index ea3a90a3f..c5193f4e1 100644 --- a/tests/testthat/test-condition_message_linter.R +++ b/tests/testthat/test-condition_message_linter.R @@ -102,8 +102,8 @@ test_that("condition_message_linter blocks simple disallowed usages", { ) "), list( - list(message = rex::rex("Don't use paste to build stop strings.")), - list(message = rex::rex("Don't use paste to build warning strings")) + list(message = rex::rex("Don't use paste to build stop strings."), line_number = 3L), + list(message = rex::rex("Don't use paste to build warning strings"), line_number = 4L) ), condition_message_linter() ) diff --git a/tests/testthat/test-conjunct_test_linter.R b/tests/testthat/test-conjunct_test_linter.R index 918d8685e..047d2456d 100644 --- a/tests/testthat/test-conjunct_test_linter.R +++ b/tests/testthat/test-conjunct_test_linter.R @@ -19,22 +19,18 @@ test_that("conjunct_test_linter skips allowed usages of expect_true", { }) test_that("conjunct_test_linter blocks && conditions with expect_true()", { - expect_lint( - "expect_true(x && y)", - rex::rex("Instead of expect_true(A && B), write multiple expectations"), - conjunct_test_linter() - ) + linter <- conjunct_test_linter() + lint_msg <- + rex::rex("Write multiple expectations like expect_true(A) and expect_true(B) instead of expect_true(A && B)") - expect_lint( - "expect_true(x && y && z)", - rex::rex("Instead of expect_true(A && B), write multiple expectations"), - conjunct_test_linter() - ) + expect_lint("expect_true(x && y)", lint_msg, linter) + expect_lint("expect_true(x && y && z)", lint_msg, linter) }) test_that("conjunct_test_linter blocks || conditions with expect_false()", { linter <- conjunct_test_linter() - lint_msg <- rex::rex("Instead of expect_false(A || B), write multiple expectations") + lint_msg <- + rex::rex("Write multiple expectations like expect_false(A) and expect_false(B) instead of expect_false(A || B)") expect_lint("expect_false(x || y)", lint_msg, linter) expect_lint("expect_false(x || y || z)", lint_msg, linter) @@ -59,7 +55,7 @@ test_that("conjunct_test_linter skips allowed stopifnot() and assert_that() usag test_that("conjunct_test_linter blocks simple disallowed usages of stopifnot() and assert_that()", { linter <- conjunct_test_linter() - lint_msg <- function(fun) rex::rex("Instead of ", fun, "(A && B), write multiple conditions") + lint_msg <- function(fun) rex::rex("Write multiple conditions like ", fun, "(A, B) instead of ", fun, "(A && B)") expect_lint("stopifnot(x && y)", lint_msg("stopifnot"), linter) expect_lint("stopifnot(x && y && z)", lint_msg("stopifnot"), linter) @@ -78,7 +74,7 @@ test_that("conjunct_test_linter's allow_named_stopifnot argument works", { ) expect_lint( "stopifnot('x is a logical scalar' = length(x) == 1 && is.logical(x) && !is.na(x))", - rex::rex("Instead of stopifnot(A && B), write multiple conditions"), + rex::rex("Write multiple conditions like stopifnot(A, B)"), conjunct_test_linter(allow_named_stopifnot = FALSE) ) }) @@ -131,3 +127,17 @@ test_that("filter() is assumed to be dplyr::filter() by default, unless o/w spec linter ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + stopifnot(A && B) + filter(DF, A & B) + }"), + list( + list("stopifnot", line_number = 2L), + list("filter", line_number = 3L) + ), + conjunct_test_linter() + ) +}) diff --git a/tests/testthat/test-consecutive_assertion_linter.R b/tests/testthat/test-consecutive_assertion_linter.R index 362e3ba18..35fe6d3f6 100644 --- a/tests/testthat/test-consecutive_assertion_linter.R +++ b/tests/testthat/test-consecutive_assertion_linter.R @@ -100,6 +100,22 @@ test_that("Mixing test functions is fine", { ) }) +test_that("lints vectorize", { + expect_lint( + trim_some("{ + stopifnot(A) + stopifnot(B) + assert_that(C) + assert_that(D) + }"), + list( + list("stopifnot", line_number = 2L), + list("assert_that", line_number = 4L) + ), + consecutive_assertion_linter() + ) +}) + test_that("old name consecutive_stopifnot_linter() is deprecated", { expect_warning( { @@ -111,3 +127,19 @@ test_that("old name consecutive_stopifnot_linter() is deprecated", { expect_lint("stopifnot(x); y; stopifnot(z)", NULL, old_linter) expect_lint("stopifnot(x); stopifnot(y)", "Unify consecutive calls", old_linter) }) + +test_that("interceding = assignments aren't linted", { + expect_lint( + trim_some("{ + stopifnot(A) + x = 1 + stopifnot(B) + + assert_that(C) + z = 3 + assert_that(D) + }"), + NULL, + consecutive_assertion_linter() + ) +}) diff --git a/tests/testthat/test-consecutive_mutate_linter.R b/tests/testthat/test-consecutive_mutate_linter.R index 641a0b359..044ad18ad 100644 --- a/tests/testthat/test-consecutive_mutate_linter.R +++ b/tests/testthat/test-consecutive_mutate_linter.R @@ -152,3 +152,21 @@ test_that("native pipe is linted", { # Ditto mixed pipes expect_lint("DF %>% mutate(a = 1) |> mutate(b = 2)", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Unify consecutive calls to mutate().") + + expect_lint( + trim_some(" + DF %>% + mutate(a = 1) %>% + mutate(b = 2) %>% + mutate(c = 3) + "), + list( + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 4L) + ), + consecutive_mutate_linter() + ) +}) diff --git a/tests/testthat/test-cyclocomp_linter.R b/tests/testthat/test-cyclocomp_linter.R index 9162c75c7..4f2b463f7 100644 --- a/tests/testthat/test-cyclocomp_linter.R +++ b/tests/testthat/test-cyclocomp_linter.R @@ -1,7 +1,7 @@ test_that("returns the correct linting", { cc_linter_1 <- cyclocomp_linter(1L) cc_linter_2 <- cyclocomp_linter(2L) - lint_msg <- rex::rex("Functions should have cyclomatic complexity") + lint_msg <- rex::rex("Reduce the cyclomatic complexity of this function") expect_lint("if (TRUE) 1 else 2", NULL, cc_linter_2) expect_lint("if (TRUE) 1 else 2", lint_msg, cc_linter_1) @@ -40,7 +40,7 @@ test_that("returns the correct linting", { expect_lint(complex_lines, lint_msg, cc_linter_2) expect_lint( complex_lines, - "should have cyclomatic complexity of less than 2, this has 10", + list(rex::rex("Reduce the cyclomatic complexity of this function from 10 to at most 2."), line_number = 1L), cc_linter_2 ) expect_lint(complex_lines, NULL, cyclocomp_linter(10L)) diff --git a/tests/testthat/test-duplicate_argument_linter.R b/tests/testthat/test-duplicate_argument_linter.R index 4c6bba76d..44040ab26 100644 --- a/tests/testthat/test-duplicate_argument_linter.R +++ b/tests/testthat/test-duplicate_argument_linter.R @@ -11,7 +11,7 @@ test_that("duplicate_argument_linter doesn't block allowed usages", { test_that("duplicate_argument_linter blocks disallowed usages", { linter <- duplicate_argument_linter() - lint_msg <- rex::rex("Duplicate arguments in function call.") + lint_msg <- rex::rex("Avoid duplicate arguments in function calls.") expect_lint("fun(arg = 1, arg = 2)", lint_msg, linter) expect_lint("fun(arg = 1, 'arg' = 2)", lint_msg, linter) @@ -21,44 +21,49 @@ test_that("duplicate_argument_linter blocks disallowed usages", { expect_lint("dt[i = 1, i = 2]", lint_msg, linter) expect_lint( - "list( - var = 1, - var = 2 - )", + trim_some(" + list( + var = 1, + var = 2 + ) + "), lint_msg, linter ) }) test_that("duplicate_argument_linter respects except argument", { + linter_list <- duplicate_argument_linter(except = "list") + linter_all <- duplicate_argument_linter(except = character()) + expect_lint( "list( var = 1, var = 2 )", NULL, - duplicate_argument_linter(except = "list") + linter_list ) expect_lint( "(function(x, y) x + y)(x = 1) list(var = 1, var = 2)", NULL, - duplicate_argument_linter(except = "list") + linter_list ) expect_lint( "fun(` ` = 1, ` ` = 2)", - list(message = rex::rex("Duplicate arguments in function call.")), - duplicate_argument_linter(except = character()) + rex::rex("Avoid duplicate arguments in function calls."), + linter_all ) expect_lint( "function(arg = 1, arg = 1) {}", - list(message = rex::rex("Repeated formal argument 'arg'.")), - duplicate_argument_linter(except = character()) + rex::rex("Repeated formal argument 'arg'."), + linter_all ) }) @@ -95,3 +100,163 @@ test_that("doesn't lint duplicated arguments in allowed functions", { linter ) }) + +test_that("interceding comments don't trip up logic", { + linter <- duplicate_argument_linter() + lint_msg <- rex::rex("Avoid duplicate arguments") + + # comment before the EQ_SUB + # actually this case "just works" even before #2402 since + # get_r_string() returns NA for both argument names + expect_lint( + trim_some(" + fun( + arg # xxx + = 1, + arg # yyy + = 2 + ) + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg # xxx + = 1, + arg = 2 + ) + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg = 1, + arg # yyy + = 2 + ) + "), + list(lint_msg, line_number = 3L), + linter + ) + + # comment after the EQ_SUB + expect_lint( + trim_some(" + fun( + arg = # xxx + 1, + arg = # yyy + 2 + ) + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg = # xxx + 1, + arg = 2 + ) + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg = 1, + arg = # yyy + 2 + ) + "), + list(lint_msg, line_number = 3L), + linter + ) + + # comment after the arg value + expect_lint( + trim_some(" + fun( + arg = 1 # xxx + , + arg = 2 # yyy + ) + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg = 1 # xxx + , + arg = 2 + ) + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg = 1, + arg = 2 # yyy + ) + "), + list(lint_msg, line_number = 3L), + linter + ) + + # comment after the OP-COMMA + expect_lint( + trim_some(" + fun( + arg = 1, # xxx + arg = 2 # yyy + ) + "), + list(lint_msg, line_number = 3L), + linter + ) + + expect_lint( + trim_some(" + fun( + arg = 1, # xxx + arg = 2 + ) + "), + list(lint_msg, line_number = 3L), + linter + ) +}) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Avoid duplicate arguments") + + expect_lint( + trim_some("{ + c(a = 1, a = 2, a = 3) + list(b = 1, b = 2, b = 3) + }"), + list( + list(lint_msg, line_number = 2L, column_number = 12L), + list(lint_msg, line_number = 2L, column_number = 19L), + list(lint_msg, line_number = 3L, column_number = 15L), + list(lint_msg, line_number = 3L, column_number = 22L) + ), + duplicate_argument_linter() + ) +}) diff --git a/tests/testthat/test-empty_assignment_linter.R b/tests/testthat/test-empty_assignment_linter.R index 01aa216bc..8bf39b34a 100644 --- a/tests/testthat/test-empty_assignment_linter.R +++ b/tests/testthat/test-empty_assignment_linter.R @@ -28,3 +28,19 @@ test_that("empty_assignment_linter blocks disallowed usages", { # LHS of assignment doesn't matter expect_lint("env$obj <- {}", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Assign NULL explicitly or, whenever possible, allocate the empty object") + + expect_lint( + trim_some("{ + x <- {} + y = {} + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + empty_assignment_linter() + ) +}) diff --git a/tests/testthat/test-equals_na_linter.R b/tests/testthat/test-equals_na_linter.R index 34f9e6f9c..26109e30b 100644 --- a/tests/testthat/test-equals_na_linter.R +++ b/tests/testthat/test-equals_na_linter.R @@ -27,7 +27,7 @@ patrick::with_parameters_test_that( "equals_na_linter blocks disallowed usages for all combinations of operators and types of NAs", expect_lint( paste("x", operation, type_na), - rex::rex("Use is.na for comparisons to NA (not == or != or %in%)"), + rex::rex("Use is.na() instead of x ", operation, " NA"), equals_na_linter() ), .cases = tibble::tribble( @@ -52,15 +52,31 @@ patrick::with_parameters_test_that( test_that("equals_na_linter blocks disallowed usages in edge cases", { linter <- equals_na_linter() - lint_msg <- rex::rex("Use is.na for comparisons to NA (not == or != or %in%)") + lint_msg_part <- "Use is.na() instead of x " # missing spaces around operators - expect_lint("x==NA", list(message = lint_msg, line_number = 1L, column_number = 1L), linter) - expect_lint("x!=NA", list(message = lint_msg, line_number = 1L, column_number = 1L), linter) + expect_lint( + "x==NA", + list(message = rex::rex(lint_msg_part, "== NA"), line_number = 1L, column_number = 1L), + linter + ) + expect_lint( + "x!=NA", + list(message = rex::rex(lint_msg_part, "!= NA"), line_number = 1L, column_number = 1L), + linter + ) # order doesn't matter - expect_lint("NA == x", list(message = lint_msg, line_number = 1L, column_number = 1L), linter) + expect_lint( + "NA == x", + list(message = rex::rex(lint_msg_part, "== NA"), line_number = 1L, column_number = 1L), + linter + ) # correct line number for multiline code - expect_lint("x ==\nNA", list(line_number = 1L, column_number = 1L, ranges = list(c(1L, 4L))), linter) + expect_lint( + "x ==\nNA", + list(line_number = 1L, column_number = 1L, ranges = list(c(1L, 4L))), + linter + ) }) diff --git a/tests/testthat/test-expect_comparison_linter.R b/tests/testthat/test-expect_comparison_linter.R index 6e99594d8..cf1a349aa 100644 --- a/tests/testthat/test-expect_comparison_linter.R +++ b/tests/testthat/test-expect_comparison_linter.R @@ -11,37 +11,56 @@ test_that("expect_comparison_linter skips allowed usages", { # expect_gt() and friends don't have an info= argument expect_lint("expect_true(x > y, info = 'x is bigger than y yo')", NULL, linter) + + # expect_true() used incorrectly, and as executed the first argument is not a lint + expect_lint("expect_true(is.count(n_draws), n_draws > 1)", NULL, linter) }) test_that("expect_comparison_linter blocks simple disallowed usages", { + linter <- expect_comparison_linter() + expect_lint( "expect_true(x > y)", rex::rex("expect_gt(x, y) is better than expect_true(x > y)."), - expect_comparison_linter() + linter ) # namespace qualification is irrelevant expect_lint( "testthat::expect_true(x < y)", rex::rex("expect_lt(x, y) is better than expect_true(x < y)."), - expect_comparison_linter() + linter ) expect_lint( "expect_true(foo(x) >= y[[2]])", rex::rex("expect_gte(x, y) is better than expect_true(x >= y)."), - expect_comparison_linter() + linter ) expect_lint( "expect_true(x <= y)", rex::rex("expect_lte(x, y) is better than expect_true(x <= y)."), - expect_comparison_linter() + linter ) expect_lint( "expect_true(x == (y == 2))", rex::rex("expect_identical(x, y) is better than expect_true(x == y)."), + linter + ) +}) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + expect_true(x < y) + expect_true(y > z) + }"), + list( + list(rex::rex("expect_lt("), line_number = 2L), + list(rex::rex("expect_gt("), line_number = 3L) + ), expect_comparison_linter() ) }) diff --git a/tests/testthat/test-expect_identical_linter.R b/tests/testthat/test-expect_identical_linter.R index fe80afd9e..d5e26548a 100644 --- a/tests/testthat/test-expect_identical_linter.R +++ b/tests/testthat/test-expect_identical_linter.R @@ -50,3 +50,19 @@ test_that("expect_identical_linter skips 3e cases needing expect_equal", { test_that("expect_identical_linter skips calls using ...", { expect_lint("expect_equal(x, y, ...)", NULL, expect_identical_linter()) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Use expect_identical(x, y) by default; resort to expect_equal() only when needed") + + expect_lint( + trim_some("{ + expect_equal(x, 1) + expect_true(identical(x, y)) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + expect_identical_linter() + ) +}) diff --git a/tests/testthat/test-expect_length_linter.R b/tests/testthat/test-expect_length_linter.R index 4f220e6ce..79176ab76 100644 --- a/tests/testthat/test-expect_length_linter.R +++ b/tests/testthat/test-expect_length_linter.R @@ -1,49 +1,50 @@ test_that("expect_length_linter skips allowed usages", { - expect_lint("expect_equal(nrow(x), 4L)", NULL, expect_length_linter()) + linter <- expect_length_linter() + + expect_lint("expect_equal(nrow(x), 4L)", NULL, linter) # NB: also applies to tinytest, but it's sufficient to test testthat - expect_lint("testthat::expect_equal(nrow(x), 4L)", NULL, expect_length_linter()) + expect_lint("testthat::expect_equal(nrow(x), 4L)", NULL, linter) # only check the first argument. yoda tests in the second argument will be # missed, but there are legitimate uses of length() in argument 2 - expect_lint("expect_equal(nrow(x), length(y))", NULL, expect_length_linter()) + expect_lint("expect_equal(nrow(x), length(y))", NULL, linter) # expect_length() doesn't have info= or label= arguments - expect_lint("expect_equal(length(x), n, info = 'x should have size n')", NULL, expect_length_linter()) - expect_lint("expect_equal(length(x), n, label = 'x size')", NULL, expect_length_linter()) - expect_lint("expect_equal(length(x), n, expected.label = 'target size')", NULL, expect_length_linter()) + expect_lint("expect_equal(length(x), n, info = 'x should have size n')", NULL, linter) + expect_lint("expect_equal(length(x), n, label = 'x size')", NULL, linter) + expect_lint("expect_equal(length(x), n, expected.label = 'target size')", NULL, linter) }) test_that("expect_length_linter blocks simple disallowed usages", { - expect_lint( - "expect_equal(length(x), 2L)", - rex::rex("expect_length(x, n) is better than expect_equal(length(x), n)"), - expect_length_linter() - ) + linter <- expect_length_linter() + lint_msg <- rex::rex("expect_length(x, n) is better than expect_equal(length(x), n)") - expect_lint( - "testthat::expect_equal(length(DF), length(old))", - rex::rex("expect_length(x, n) is better than expect_equal(length(x), n)"), - expect_length_linter() - ) + expect_lint("expect_equal(length(x), 2L)", lint_msg, linter) + expect_lint("testthat::expect_equal(length(DF), length(old))", lint_msg, linter) # yoda test cases - expect_lint( - "expect_equal(2, length(x))", - rex::rex("expect_length(x, n) is better than expect_equal(length(x), n)"), - expect_length_linter() - ) + expect_lint("expect_equal(2, length(x))", lint_msg, linter) + expect_lint("expect_equal(2L, length(x))", lint_msg, linter) +}) +test_that("expect_length_linter blocks expect_identical usage as well", { expect_lint( - "expect_equal(2L, length(x))", - rex::rex("expect_length(x, n) is better than expect_equal(length(x), n)"), + "expect_identical(length(x), 2L)", + rex::rex("expect_length(x, n) is better than expect_identical(length(x), n)"), expect_length_linter() ) }) -test_that("expect_length_linter blocks expect_identical usage as well", { +test_that("lints vectorize", { expect_lint( - "expect_identical(length(x), 2L)", - rex::rex("expect_length(x, n) is better than expect_identical(length(x), n)"), + trim_some("{ + expect_equal(length(x), n) + expect_identical(length(x), n) + }"), + list( + list("expect_equal", line_number = 2L), + list("expect_identical", line_number = 3L) + ), expect_length_linter() ) }) diff --git a/tests/testthat/test-expect_lint.R b/tests/testthat/test-expect_lint.R index d2152854e..622882884 100644 --- a/tests/testthat/test-expect_lint.R +++ b/tests/testthat/test-expect_lint.R @@ -42,8 +42,8 @@ test_that("multiple checks", { expect_success(expect_lint("a=1; b=2", list(c(message = lint_msg), c(message = lint_msg)), linter)) expect_success(expect_lint("a=1; b=2", list(c(line_number = 1L), c(linter = "assignment_linter")), linter)) expect_success(expect_lint("a=1; b=2", list(lint_msg, c(line = "a=1; b=2", type = "warning")), linter)) - expect_success(expect_lint(c("a=1", "b=2"), list(c(line_number = 1L), c(line_number = 2L)), linter)) - expect_failure(expect_lint(c("a=1", "b=2"), list(c(line_number = 2L), c(line_number = 2L)), linter)) + expect_success(expect_lint("a=1\nb=2", list(c(line_number = 1L), c(line_number = 2L)), linter)) + expect_failure(expect_lint("a=1\nb=2", list(c(line_number = 2L), c(line_number = 2L)), linter)) expect_success(expect_lint("a=1; b=2", list(list(line_number = 1L), list(line_number = 2L)), linter)) expect_failure(expect_lint("a=1; b=2", list(list(line_number = 2L), list(line_number = 2L)), linter)) diff --git a/tests/testthat/test-expect_named_linter.R b/tests/testthat/test-expect_named_linter.R index 804b6dfb4..662be5a6b 100644 --- a/tests/testthat/test-expect_named_linter.R +++ b/tests/testthat/test-expect_named_linter.R @@ -16,29 +16,32 @@ test_that("expect_named_linter skips allowed usages", { }) test_that("expect_named_linter blocks simple disallowed usages", { - expect_lint( - "expect_equal(names(x), 'a')", - rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)"), - expect_named_linter() - ) + linter <- expect_named_linter() + lint_msg <- rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)") - expect_lint( - "testthat::expect_equal(names(DF), names(old))", - rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)"), - expect_named_linter() - ) + expect_lint("expect_equal(names(x), 'a')", lint_msg, linter) + expect_lint("testthat::expect_equal(names(DF), names(old))", lint_msg, linter) + expect_lint("expect_equal('a', names(x))", lint_msg, linter) +}) +test_that("expect_named_linter blocks expect_identical usage as well", { expect_lint( - "expect_equal('a', names(x))", - rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)"), + "expect_identical(names(x), 'a')", + rex::rex("expect_named(x, n) is better than expect_identical(names(x), n)"), expect_named_linter() ) }) -test_that("expect_named_linter blocks expect_identical usage as well", { +test_that("lints vectorize", { expect_lint( - "expect_identical(names(x), 'a')", - rex::rex("expect_named(x, n) is better than expect_identical(names(x), n)"), + trim_some("{ + expect_equal(names(x), nm) + expect_identical(names(x), nm) + }"), + list( + list("expect_equal", line_number = 2L), + list("expect_identical", line_number = 3L) + ), expect_named_linter() ) }) diff --git a/tests/testthat/test-expect_not_linter.R b/tests/testthat/test-expect_not_linter.R index 2020b4b17..6b17c2189 100644 --- a/tests/testthat/test-expect_not_linter.R +++ b/tests/testthat/test-expect_not_linter.R @@ -19,3 +19,19 @@ test_that("expect_not_linter blocks simple disallowed usages", { expect_lint("expect_false(!foo(x))", lint_msg, linter) expect_lint("testthat::expect_true(!(x && y))", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("expect_false(x) is better than expect_true(!x), and vice versa.") + + expect_lint( + trim_some("{ + expect_true(!x) + expect_false(!y) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + expect_not_linter() + ) +}) diff --git a/tests/testthat/test-expect_null_linter.R b/tests/testthat/test-expect_null_linter.R index b889e9122..dc93eb400 100644 --- a/tests/testthat/test-expect_null_linter.R +++ b/tests/testthat/test-expect_null_linter.R @@ -15,30 +15,48 @@ test_that("expect_null_linter skips allowed usages", { }) test_that("expect_null_linter blocks simple disallowed usages", { + linter <- expect_null_linter() + expect_lint( "expect_equal(x, NULL)", rex::rex("expect_null(x) is better than expect_equal(x, NULL)"), - expect_null_linter() + linter ) # expect_identical is treated the same as expect_equal expect_lint( "testthat::expect_identical(x, NULL)", rex::rex("expect_null(x) is better than expect_identical(x, NULL)"), - expect_null_linter() + linter ) # reverse order lints the same expect_lint( "expect_equal(NULL, x)", rex::rex("expect_null(x) is better than expect_equal(x, NULL)"), - expect_null_linter() + linter ) # different equivalent usage expect_lint( "expect_true(is.null(foo(x)))", rex::rex("expect_null(x) is better than expect_true(is.null(x))"), + linter + ) +}) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + expect_equal(x, NULL) + expect_identical(x, NULL) + expect_true(is.null(x)) + }"), + list( + list("expect_equal", line_number = 2L), + list("expect_identical", line_number = 3L), + list("expect_true", line_number = 4L) + ), expect_null_linter() ) }) diff --git a/tests/testthat/test-expect_s3_class_linter.R b/tests/testthat/test-expect_s3_class_linter.R index d071a8f77..acdbd2686 100644 --- a/tests/testthat/test-expect_s3_class_linter.R +++ b/tests/testthat/test-expect_s3_class_linter.R @@ -20,52 +20,46 @@ test_that("expect_s3_class_linter skips allowed usages", { }) test_that("expect_s3_class_linter blocks simple disallowed usages", { + linter <- expect_s3_class_linter() + expect_lint( "expect_equal(class(x), 'data.frame')", rex::rex("expect_s3_class(x, k) is better than expect_equal(class(x), k)"), - expect_s3_class_linter() + linter ) # works when testing against a sequence of classes too expect_lint( "expect_equal(class(x), c('data.table', 'data.frame'))", rex::rex("expect_s3_class(x, k) is better than expect_equal(class(x), k)"), - expect_s3_class_linter() + linter ) # expect_identical is treated the same as expect_equal expect_lint( "testthat::expect_identical(class(x), 'lm')", rex::rex("expect_s3_class(x, k) is better than expect_identical(class(x), k)"), - expect_s3_class_linter() + linter ) # yoda test with string literal in first arg also caught expect_lint( "expect_equal('data.frame', class(x))", rex::rex("expect_s3_class(x, k) is better than expect_equal(class(x), k)"), - expect_s3_class_linter() + linter ) # different equivalent usages expect_lint( "expect_true(is.table(foo(x)))", rex::rex("expect_s3_class(x, k) is better than expect_true(is.(x))"), - expect_s3_class_linter() + linter ) expect_lint( "expect_true(inherits(x, 'table'))", rex::rex("expect_s3_class(x, k) is better than expect_true(is.(x))"), - expect_s3_class_linter() + linter ) - - # TODO(michaelchirico): consider more carefully which sorts of class(x) %in% . and - # . %in% class(x) calls should be linted - #> expect_lint( - #> "expect_true('lm' %in% class(x))", - #> "expect_s3_class\\(x, k\\) is better than expect_equal\\(class\\(x\\), k", - #> expect_s3_class_linter - #> ) }) local({ @@ -87,3 +81,19 @@ local({ is_class = is_classes ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + expect_true(is.factor(x)) + expect_true(inherits(x, k)) + expect_equal(class(x), k) + }"), + list( + list(rex::rex("is."), line_number = 2L), + list(rex::rex("is."), line_number = 3L), + list("expect_equal", line_number = 4L) + ), + expect_s3_class_linter() + ) +}) diff --git a/tests/testthat/test-expect_s4_class.R b/tests/testthat/test-expect_s4_class_linter.R similarity index 55% rename from tests/testthat/test-expect_s4_class.R rename to tests/testthat/test-expect_s4_class_linter.R index 996fc3a91..9892cabff 100644 --- a/tests/testthat/test-expect_s4_class.R +++ b/tests/testthat/test-expect_s4_class_linter.R @@ -12,16 +12,26 @@ test_that("expect_s4_class_linter skips allowed usages", { }) test_that("expect_s4_class blocks simple disallowed usages", { - expect_lint( - "expect_true(is(x, 'data.frame'))", - rex::rex("expect_s4_class(x, k) is better than expect_true(is(x, k))"), - expect_s4_class_linter() - ) + linter <- expect_s4_class_linter() + lint_msg <- rex::rex("expect_s4_class(x, k) is better than expect_true(is(x, k))") + expect_lint("expect_true(is(x, 'data.frame'))", lint_msg, linter) # namespace qualification is irrelevant + expect_lint("testthat::expect_true(methods::is(x, 'SpatialPolygonsDataFrame'))", lint_msg, linter) +}) + +test_that("lints vectorize", { + lint_msg <- rex::rex("expect_s4_class(x, k) is better than expect_true(is(x, k))") + expect_lint( - "testthat::expect_true(methods::is(x, 'SpatialPolygonsDataFrame'))", - rex::rex("expect_s4_class(x, k) is better than expect_true(is(x, k))"), + trim_some("{ + expect_true(is(x, 'data.frame')) + expect_true(is(x, 'SpatialPolygonsDataFrame')) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), expect_s4_class_linter() ) }) diff --git a/tests/testthat/test-expect_true_false_linter.R b/tests/testthat/test-expect_true_false_linter.R index e0bee7e12..76ed5c42c 100644 --- a/tests/testthat/test-expect_true_false_linter.R +++ b/tests/testthat/test-expect_true_false_linter.R @@ -4,23 +4,39 @@ test_that("expect_true_false_linter skips allowed usages", { }) test_that("expect_true_false_linter blocks simple disallowed usages", { + linter <- expect_true_false_linter() + expect_lint( "expect_equal(foo(x), TRUE)", rex::rex("expect_true(x) is better than expect_equal(x, TRUE)"), - expect_true_false_linter() + linter ) # expect_identical is treated the same as expect_equal expect_lint( "testthat::expect_identical(x, FALSE)", rex::rex("expect_false(x) is better than expect_identical(x, FALSE)"), - expect_true_false_linter() + linter ) # also caught when TRUE/FALSE is the first argument expect_lint( "expect_equal(TRUE, foo(x))", rex::rex("expect_true(x) is better than expect_equal(x, TRUE)"), + linter + ) +}) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + expect_equal(x, TRUE) + expect_equal(x, FALSE) + }"), + list( + list("expect_true", line_number = 2L), + list("expect_false", line_number = 3L) + ), expect_true_false_linter() ) }) diff --git a/tests/testthat/test-expect_type_linter.R b/tests/testthat/test-expect_type_linter.R index fde4f23ee..a88ac8959 100644 --- a/tests/testthat/test-expect_type_linter.R +++ b/tests/testthat/test-expect_type_linter.R @@ -69,3 +69,17 @@ local({ is_type = is_types ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + expect_true(is.integer(x)) + expect_equal(typeof(x), 'double') + }"), + list( + list("expect_true", line_number = 2L), + list("expect_equal", line_number = 3L) + ), + expect_type_linter() + ) +}) diff --git a/tests/testthat/test-extraction_operator_linter.R b/tests/testthat/test-extraction_operator_linter.R index 09883b728..810971a2f 100644 --- a/tests/testthat/test-extraction_operator_linter.R +++ b/tests/testthat/test-extraction_operator_linter.R @@ -1,5 +1,14 @@ +test_that("extraction_operator_linter generates deprecation warning", { + expect_warning( + extraction_operator_linter(), + rex::rex("Linter extraction_operator_linter was deprecated") + ) +}) + test_that("extraction_operator_linter skips allowed usages", { - linter <- extraction_operator_linter() + expect_warning({ + linter <- extraction_operator_linter() + }) expect_lint("x[[1]]", NULL, linter) expect_lint("x[-1]", NULL, linter) @@ -10,7 +19,9 @@ test_that("extraction_operator_linter skips allowed usages", { }) test_that("extraction_operator_linter blocks disallowed usages", { - linter <- extraction_operator_linter() + expect_warning({ + linter <- extraction_operator_linter() + }) msg_b <- rex::escape("Use `[[` instead of `[` to extract an element.") msg_d <- rex::escape("Use `[[` instead of `$` to extract an element.") diff --git a/tests/testthat/test-fixed_regex_linter.R b/tests/testthat/test-fixed_regex_linter.R index 0fb6a8fb2..371848200 100644 --- a/tests/testthat/test-fixed_regex_linter.R +++ b/tests/testthat/test-fixed_regex_linter.R @@ -238,15 +238,13 @@ test_that("fixed replacements vectorize and recognize str_detect", { linter <- fixed_regex_linter() # properly vectorized expect_lint( - trim_some(" - c( - grepl('abcdefg', x), - grepl('a[.]\\\\.b\\n', x) - ) - "), + trim_some("{ + grepl('abcdefg', x) + grepl('a[.]\\\\.b\\n', x) + }"), list( - rex::rex('Here, you can use "abcdefg" with fixed = TRUE'), - rex::rex('Here, you can use "a..b\\n" with fixed = TRUE') + list(rex::rex('Use "abcdefg" with fixed = TRUE'), line_number = 2L), + list(rex::rex('Use "a..b\\n" with fixed = TRUE'), line_number = 3L) ), linter ) @@ -254,7 +252,7 @@ test_that("fixed replacements vectorize and recognize str_detect", { # stringr hint works expect_lint( "str_detect(x, 'abc')", - rex::rex('Here, you can use stringr::fixed("abc") as the pattern'), + rex::rex('Use stringr::fixed("abc") as the pattern'), linter ) }) @@ -267,24 +265,11 @@ test_that("fixed replacement is correct with UTF-8", { expect_lint( "grepl('[\\U{1D4D7}]', x)", - rex::rex('Here, you can use "\U1D4D7" with fixed = TRUE'), + rex::rex('Use "\U1D4D7" with fixed = TRUE'), fixed_regex_linter() ) }) -# TODO(michaelchirico): one difference for stringr functions vs. base is that -# stringr is much friendlier to piping, so that -# > str %>% str_replace_all("x$", "y") -# actually doesn't need fixed(), but the logic now is only looking at "y" -# since it's the second argument and a non-regex string. Similarly, -# > str %>% str_detect("x") -# is a false negative. thankfully there appear to be few false positives here - -# TODO(michaelchirico): we could in principle build in logic to detect whether -# perl=TRUE and interpret "regex or not" accordingly. One place -# up in practice is for '\<', which is a special character in default -# regex but not in PCRE. Empirically relevant for HTML-related regex e.g. \\ - #' Generate a string with a non-printable Unicode entry robust to test environment #' #' Non-printable unicode behaves wildly different with `encodeString()` @@ -302,51 +287,67 @@ robust_non_printable_unicode <- function() { } # styler: off -patrick::with_parameters_test_that("fixed replacements are correct", { - skip_if( - regex_expr %in% c("abc\\U{A0DEF}ghi", "[\\U1d4d7]", "[\\U{1D4D7}]", "\\u{A0}\\U{0001d4d7}") && - .Platform$OS.type == "windows" && - !hasName(R.Version(), "crt"), - message = "UTF-8 support is required" +local({ + .cases <- tibble::tribble( + ~.test_name, ~regex_expr, ~fixed_expr, + "[.]", "[.]", ".", + '[\\\"]', '[\\\"]', '\\"', + "[]]", "[]]", "]", + "\\\\.", "\\\\.", ".", + "\\\\:", "\\\\:", ":", + "\\\\<", "\\\\<", "<", + "\\\\$", "\\\\$", "$", + "[\\1]", "[\\1]", "\\001", + "\\1", "\\1", "\\001", + "[\\12]", "[\\12]", "\\n", + "[\\123]", "[\\123]", "S", + "a[*]b", "a[*]b", "a*b", + "abcdefg", "abcdefg", "abcdefg", + "abc\\U{A0DEF}ghi", "abc\\U{A0DEF}ghi", robust_non_printable_unicode(), + "a-z", "a-z", "a-z", + "[\\n]", "[\\n]", "\\n", + "\\n", "\n", "\\n", + "[\\u01]", "[\\u01]", "\\001", + "[\\u012]", "[\\u012]", "\\022", + "[\\u0123]", "[\\u0123]", "\u0123", + "[\\u{1}]", "[\\u{1}]", "\\001", + "[\\U1d4d7]", "[\\U1d4d7]", "\U1D4D7", + "[\\U{1D4D7}]", "[\\U{1D4D7}]", "\U1D4D7", + "[\\U8]", "[\\U8]", "\\b", + "\\u{A0}", "\\u{A0}", "\uA0", + "\\u{A0}\\U{0001d4d7}", "\\u{A0}\\U{0001d4d7}", "\uA0\U1D4D7", + "[\\uF]", "[\\uF]", "\\017", + "[\\U{F7D5}]", "[\\U{F7D5}]", "\UF7D5", + "[\\x32]", "[\\x32]", "2", + "[\\xa]", "[\\xa]", "\\n" ) - expect_lint( - sprintf("grepl('%s', x)", regex_expr), - rex::rex(sprintf('Here, you can use "%s" with fixed = TRUE', fixed_expr)), - fixed_regex_linter() + if (.Platform$OS.type == "windows" && !hasName(R.Version(), "crt")) { + skip_cases <- c( + # These require UTF-8 support + "abc\\U{A0DEF}ghi", "[\\U1d4d7]", "[\\U{1D4D7}]", "\\u{A0}\\U{0001d4d7}", + # R version-specific difference in output message on Windows (probably r80051) + if (getRversion() == "4.0.4") "[\\U{F7D5}]" + ) + } else { + skip_cases <- character() + } + patrick::with_parameters_test_that( + "fixed replacements are correct", + { + # TODO(google/patrick#19): handle this more cleanly by skipping up-front + skip_if( + regex_expr %in% skip_cases, + sprintf("regex '%s' is not supported on this system", regex_expr) + ) + expect_lint( + sprintf("grepl('%s', x)", regex_expr), + rex::rex(sprintf('Use "%s" with fixed = TRUE', fixed_expr)), + fixed_regex_linter() + ) + }, + .cases = .cases ) -}, .cases = tibble::tribble( - ~.test_name, ~regex_expr, ~fixed_expr, - "[.]", "[.]", ".", - '[\\\"]', '[\\\"]', '\\"', - "[]]", "[]]", "]", - "\\\\.", "\\\\.", ".", - "\\\\:", "\\\\:", ":", - "\\\\<", "\\\\<", "<", - "\\\\$", "\\\\$", "$", - "[\\1]", "[\\1]", "\\001", - "\\1", "\\1", "\\001", - "[\\12]", "[\\12]", "\\n", - "[\\123]", "[\\123]", "S", - "a[*]b", "a[*]b", "a*b", - "abcdefg", "abcdefg", "abcdefg", - "abc\\U{A0DEF}ghi", "abc\\U{A0DEF}ghi", robust_non_printable_unicode(), - "a-z", "a-z", "a-z", - "[\\n]", "[\\n]", "\\n", - "\\n", "\n", "\\n", - "[\\u01]", "[\\u01]", "\\001", - "[\\u012]", "[\\u012]", "\\022", - "[\\u0123]", "[\\u0123]", "\u0123", - "[\\u{1}]", "[\\u{1}]", "\\001", - "[\\U1d4d7]", "[\\U1d4d7]", "\U1D4D7", - "[\\U{1D4D7}]", "[\\U{1D4D7}]", "\U1D4D7", - "[\\U8]", "[\\U8]", "\\b", - "\\u{A0}", "\\u{A0}", "\uA0", - "\\u{A0}\\U{0001d4d7}", "\\u{A0}\\U{0001d4d7}", "\uA0\U1D4D7", - "[\\uF]", "[\\uF]", "\\017", - "[\\U{F7D5}]", "[\\U{F7D5}]", "\UF7D5", - "[\\x32]", "[\\x32]", "2", - "[\\xa]", "[\\xa]", "\\n" -)) +}) # styler: on test_that("'unescaped' regex can optionally be skipped", { @@ -354,7 +355,7 @@ test_that("'unescaped' regex can optionally be skipped", { expect_lint("grepl('a', x)", NULL, linter) expect_lint("str_detect(x, 'a')", NULL, linter) - expect_lint("grepl('[$]', x)", rex::rex('Here, you can use "$"'), linter) + expect_lint("grepl('[$]', x)", rex::rex('Use "$" with fixed = TRUE'), linter) }) local({ diff --git a/tests/testthat/test-for_loop_index_linter.R b/tests/testthat/test-for_loop_index_linter.R index 018a4a755..f138e1938 100644 --- a/tests/testthat/test-for_loop_index_linter.R +++ b/tests/testthat/test-for_loop_index_linter.R @@ -33,3 +33,19 @@ test_that("for_loop_index_linter blocks simple disallowed usages", { # arbitrary nesting expect_lint("for (x in foo(bar(y, baz(2, x)))) {}", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- "Don't re-use any sequence symbols as the index symbol in a for loop" + + expect_lint( + trim_some("{ + for (x in x) {} + for (y in y) {} + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + for_loop_index_linter() + ) +}) diff --git a/tests/testthat/test-function_return_linter.R b/tests/testthat/test-function_return_linter.R index f65e969f0..0a78a895f 100644 --- a/tests/testthat/test-function_return_linter.R +++ b/tests/testthat/test-function_return_linter.R @@ -75,3 +75,24 @@ test_that("function_return_linter blocks simple disallowed usages", { linter ) }) + +test_that("lints vectorize", { + linter <- function_return_linter() + lint_msg <- rex::rex("Move the assignment outside of the return() clause") + + expect_lint( + trim_some("{ + function() { + return(x <- 1) + } + function() { + return(y <- 2) + } + }"), + list( + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 6L) + ), + function_return_linter() + ) +}) diff --git a/tests/testthat/test-get_source_expressions.R b/tests/testthat/test-get_source_expressions.R index add9c3538..917a414ed 100644 --- a/tests/testthat/test-get_source_expressions.R +++ b/tests/testthat/test-get_source_expressions.R @@ -218,7 +218,10 @@ test_that("returned data structure is complete", { for (i in seq_along(lines)) { expr <- exprs$expressions[[i]] - expect_named(expr, c("filename", "line", "column", "lines", "parsed_content", "xml_parsed_content", "content")) + expect_named(expr, c( + "filename", "line", "column", "lines", "parsed_content", "xml_parsed_content", "xml_find_function_calls", + "content" + )) expect_identical(expr$filename, temp_file) expect_identical(expr$line, i) expect_identical(expr$column, 1L) @@ -229,7 +232,8 @@ test_that("returned data structure is complete", { } full_expr <- exprs$expressions[[length(lines) + 1L]] expect_named(full_expr, c( - "filename", "file_lines", "content", "full_parsed_content", "full_xml_parsed_content", "terminal_newline" + "filename", "file_lines", "content", "full_parsed_content", "full_xml_parsed_content", "xml_find_function_calls", + "terminal_newline" )) expect_identical(full_expr$filename, temp_file) expect_identical(full_expr$file_lines, lines_with_attr) @@ -245,6 +249,48 @@ test_that("returned data structure is complete", { expect_identical(exprs$lines, lines_with_attr) }) +test_that("xml_find_function_calls works as intended", { + lines <- c("foo()", "bar()", "foo()", "{ foo(); foo(); bar() }") + temp_file <- withr::local_tempfile(lines = lines) + + exprs <- get_source_expressions(temp_file) + + expect_length(exprs$expressions[[1L]]$xml_find_function_calls("foo"), 1L) + expect_length(exprs$expressions[[1L]]$xml_find_function_calls("bar"), 0L) + expect_identical( + exprs$expressions[[1L]]$xml_find_function_calls("foo"), + xml_find_all(exprs$expressions[[1L]]$xml_parsed_content, "//SYMBOL_FUNCTION_CALL[text() = 'foo']") + ) + + expect_length(exprs$expressions[[2L]]$xml_find_function_calls("foo"), 0L) + expect_length(exprs$expressions[[2L]]$xml_find_function_calls("bar"), 1L) + + expect_length(exprs$expressions[[4L]]$xml_find_function_calls("foo"), 2L) + expect_length(exprs$expressions[[4L]]$xml_find_function_calls("bar"), 1L) + expect_length(exprs$expressions[[4L]]$xml_find_function_calls(c("foo", "bar")), 3L) + + # file-level source expression contains all function calls + expect_length(exprs$expressions[[5L]]$xml_find_function_calls("foo"), 4L) + expect_length(exprs$expressions[[5L]]$xml_find_function_calls("bar"), 2L) + expect_length(exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar")), 6L) + + # Also check order is retained: + expect_identical( + exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar")), + xml_find_all(exprs$expressions[[5L]]$full_xml_parsed_content, "//SYMBOL_FUNCTION_CALL") + ) + + # Check naming and full cache + expect_identical( + exprs$expressions[[5L]]$xml_find_function_calls(NULL), + exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar")) + ) + expect_named( + exprs$expressions[[4L]]$xml_find_function_calls(c("foo", "bar"), keep_names = TRUE), + c("foo", "foo", "bar") + ) +}) + test_that("#1262: xml_parsed_content gets returned as missing even if there's no parsed_content", { tempfile <- withr::local_tempfile(lines = '"\\R"') @@ -371,10 +417,18 @@ patrick::with_parameters_test_that( linter <- eval(call(linter)) } expression <- expressions[[expression_idx]] - expect_no_warning({ - lints <- linter(expression) - }) - expect_length(lints, 0L) + is_valid_linter_level <- + (is_linter_level(linter, "expression") && is_lint_level(expression, "expression")) || + (is_linter_level(linter, "file") && is_lint_level(expression, "file")) + if (is_valid_linter_level) { + expect_no_warning({ + lints <- linter(expression) + }) + expect_length(lints, 0L) + } else { + # suppress "empty test" skips + expect_true(TRUE) + } }, .test_name = param_df$.test_name, linter = param_df$linter, diff --git a/tests/testthat/test-if_not_else_linter.R b/tests/testthat/test-if_not_else_linter.R index 27f0b1df2..f63f936ff 100644 --- a/tests/testthat/test-if_not_else_linter.R +++ b/tests/testthat/test-if_not_else_linter.R @@ -20,7 +20,7 @@ test_that("if_not_else_linter skips allowed usages", { test_that("if_not_else_linter blocks simple disallowed usages", { linter <- if_not_else_linter() - lint_msg <- rex::rex("In a simple if/else statement, prefer `if (A) x else y`") + lint_msg <- rex::rex("Prefer `if (A) x else y`") expect_lint("if (!A) x else y", lint_msg, linter) expect_lint("if (!A) x else if (!B) y else z", lint_msg, linter) @@ -65,7 +65,7 @@ test_that("multiple lints are generated correctly", { if_else(!A, x, y) }"), list( - "In a simple if/else statement", + rex::rex("Prefer `if (A) x else y`"), "Prefer `ifelse", "Prefer `fifelse", "Prefer `if_else" @@ -77,11 +77,9 @@ test_that("multiple lints are generated correctly", { test_that("exceptions= argument works", { expect_lint( "if (!is.null(x)) x else y", - "In a simple if/else statement", + rex::rex("Prefer `if (A) x else y`"), if_not_else_linter(exceptions = character()) ) expect_lint("if (!foo(x)) y else z", NULL, if_not_else_linter(exceptions = "foo")) }) - -# TODO(michaelchirico): should if (A != B) be considered as well? diff --git a/tests/testthat/test-if_switch_linter.R b/tests/testthat/test-if_switch_linter.R index b321e680e..e6b3e5fe5 100644 --- a/tests/testthat/test-if_switch_linter.R +++ b/tests/testthat/test-if_switch_linter.R @@ -77,3 +77,440 @@ test_that("multiple lints have right metadata", { if_switch_linter() ) }) + +test_that("max_branch_lines= and max_branch_expressions= arguments work", { + max_lines2_linter <- if_switch_linter(max_branch_lines = 2L) + max_lines4_linter <- if_switch_linter(max_branch_lines = 4L) + max_expr2_linter <- if_switch_linter(max_branch_expressions = 2L) + max_expr4_linter <- if_switch_linter(max_branch_expressions = 4L) + lint_msg <- rex::rex("Prefer switch() statements over repeated if/else equality tests") + + one_per_branch_lines <- trim_some(" + if (x == 'a') { + 1 + } else if (x == 'b') { + 2 + } else if (x == 'c') { + 3 + } + ") + expect_lint(one_per_branch_lines, lint_msg, max_lines2_linter) + expect_lint(one_per_branch_lines, lint_msg, max_lines4_linter) + expect_lint(one_per_branch_lines, lint_msg, max_expr2_linter) + expect_lint(one_per_branch_lines, lint_msg, max_expr4_linter) + + two_per_branch_lines <- trim_some(" + if (x == 'a') { + 1 + 2 + } else if (x == 'b') { + 3 + 4 + } else if (x == 'c') { + 5 + 6 + } + ") + expect_lint(two_per_branch_lines, lint_msg, max_lines2_linter) + expect_lint(two_per_branch_lines, lint_msg, max_lines4_linter) + expect_lint(two_per_branch_lines, lint_msg, max_expr2_linter) + expect_lint(two_per_branch_lines, lint_msg, max_expr4_linter) + + three_per_branch_lines <- trim_some(" + if (x == 'a') { + 1 + 2 + 3 + } else if (x == 'b') { + 4 + 5 + 6 + } else if (x == 'c') { + 7 + 8 + 9 + } + ") + expect_lint(three_per_branch_lines, NULL, max_lines2_linter) + expect_lint(three_per_branch_lines, lint_msg, max_lines4_linter) + expect_lint(three_per_branch_lines, NULL, max_expr2_linter) + expect_lint(three_per_branch_lines, lint_msg, max_expr4_linter) + + five_per_branch_lines <- trim_some(" + if (x == 'a') { + 1 + 2 + 3 + 4 + 5 + } else if (x == 'b') { + 6 + 7 + 8 + 9 + 10 + } else if (x == 'c') { + 11 + 12 + 13 + 14 + 15 + } + ") + expect_lint(five_per_branch_lines, NULL, max_lines2_linter) + expect_lint(five_per_branch_lines, NULL, max_lines4_linter) + expect_lint(five_per_branch_lines, NULL, max_expr2_linter) + expect_lint(five_per_branch_lines, NULL, max_expr4_linter) + + five_lines_three_expr_lines <- trim_some(" + if (x == 'a') { + 1 + 2 + foo( + x + ) + } else if (x == 'b') { + 6 + 7 + bar( + y + ) + } else if (x == 'c') { + 11 + 12 + baz( + z + ) + } + ") + expect_lint(five_lines_three_expr_lines, NULL, max_lines2_linter) + expect_lint(five_lines_three_expr_lines, NULL, max_lines4_linter) + expect_lint(five_lines_three_expr_lines, NULL, max_expr2_linter) + expect_lint( + five_lines_three_expr_lines, + list(lint_msg, line_number = 1L), + max_expr4_linter + ) + + five_expr_three_lines_lines <- trim_some(" + if (x == 'a') { + 1 + 2 + 3; 4; 5 + } else if (x == 'b') { + 6 + 7 + 8; 9; 10 + } else if (x == 'c') { + 11 + 12 + 13; 14; 15 + } + ") + expect_lint(five_expr_three_lines_lines, NULL, max_lines2_linter) + expect_lint( + five_expr_three_lines_lines, + list(lint_msg, line_number = 1L), + max_lines4_linter + ) + expect_lint(five_expr_three_lines_lines, NULL, max_expr2_linter) + expect_lint(five_expr_three_lines_lines, NULL, max_expr4_linter) +}) + +test_that("max_branch_lines= and max_branch_expressions= block over-complex switch() too", { + max_lines2_linter <- if_switch_linter(max_branch_lines = 2L) + max_lines4_linter <- if_switch_linter(max_branch_lines = 4L) + max_expr2_linter <- if_switch_linter(max_branch_expressions = 2L) + max_expr4_linter <- if_switch_linter(max_branch_expressions = 4L) + lint_msg <- rex::rex("Prefer repeated if/else statements over overly-complicated switch() statements.") + + one_per_branch_lines <- trim_some(" + switch(x, + a = { + 1 + }, + b = { + 2 + }, + c = { + 3 + } + ) + ") + expect_lint(one_per_branch_lines, NULL, max_lines2_linter) + expect_lint(one_per_branch_lines, NULL, max_lines4_linter) + expect_lint(one_per_branch_lines, NULL, max_expr2_linter) + expect_lint(one_per_branch_lines, NULL, max_expr4_linter) + + two_per_branch_lines <- trim_some(" + switch(x, + a = { + 1 + 2 + }, + b = { + 3 + 4 + }, + c = { + 5 + 6 + } + ) + ") + expect_lint(two_per_branch_lines, NULL, max_lines2_linter) + expect_lint(two_per_branch_lines, NULL, max_lines4_linter) + expect_lint(two_per_branch_lines, NULL, max_expr2_linter) + expect_lint(two_per_branch_lines, NULL, max_expr4_linter) + + three_per_branch_lines <- trim_some(" + switch(x, + a = { + 1 + 2 + 3 + }, + b = { + 4 + 5 + 6 + }, + c = { + 7 + 8 + 9 + } + ) + ") + expect_lint( + three_per_branch_lines, + list(lint_msg, line_number = 1L), + max_lines2_linter + ) + expect_lint(three_per_branch_lines, NULL, max_lines4_linter) + expect_lint( + three_per_branch_lines, + list(lint_msg, line_number = 1L), + max_expr2_linter + ) + expect_lint(three_per_branch_lines, NULL, max_expr4_linter) + + five_per_branch_lines <- trim_some(" + switch(x, + a = { + 1 + 2 + 3 + 4 + 5 + }, + b = { + 6 + 7 + 8 + 9 + 10 + }, + c = { + 11 + 12 + 13 + 14 + 15 + } + ) + ") + expect_lint(five_per_branch_lines, lint_msg, max_lines2_linter) + expect_lint(five_per_branch_lines, lint_msg, max_lines4_linter) + expect_lint(five_per_branch_lines, lint_msg, max_expr2_linter) + expect_lint(five_per_branch_lines, lint_msg, max_expr4_linter) + + five_lines_three_expr_lines <- trim_some(" + switch(x, + a = { + 1 + 2 + foo( + x + ) + }, + b = { + 6 + 7 + bar( + y + ) + }, + c = { + 11 + 12 + baz( + z + ) + } + ) + ") + expect_lint(five_lines_three_expr_lines, lint_msg, max_lines2_linter) + expect_lint(five_lines_three_expr_lines, lint_msg, max_lines4_linter) + expect_lint(five_lines_three_expr_lines, lint_msg, max_expr2_linter) + expect_lint(five_lines_three_expr_lines, NULL, max_expr4_linter) + + five_expr_three_lines_lines <- trim_some(" + switch(x, + a = { + 1 + 2 + 3; 4; 5 + }, + b = { + 6 + 7 + 8; 9; 10 + }, + c = { + 11 + 12 + 13; 14; 15 + } + ) + ") + expect_lint(five_expr_three_lines_lines, lint_msg, max_lines2_linter) + expect_lint(five_expr_three_lines_lines, NULL, max_lines4_linter) + expect_lint(five_expr_three_lines_lines, lint_msg, max_expr2_linter) + expect_lint(five_expr_three_lines_lines, lint_msg, max_expr4_linter) +}) + +test_that("max_branch_lines= and max_branch_expressions= interact correctly", { + linter <- if_switch_linter(max_branch_lines = 5L, max_branch_expressions = 3L) + lint_msg <- rex::rex("Prefer switch() statements over repeated if/else equality tests") + + expect_lint( + trim_some(" + if (x == 'a') { + 1 + } else if (x == 'b') { + 2 + } else if (x == 'c') { + 3 + } + "), + lint_msg, + linter + ) + + expect_lint( + trim_some(" + if (x == 'a') { + foo( + x1, + x2, + x3, + x4 + ) + } else if (x == 'b') { + 2 + } else if (x == 'c') { + 3 + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x == 'a') { + 1; 2; 3; 4 + } else if (x == 'b') { + 5 + } else if (x == 'c') { + 6 + } + "), + NULL, + linter + ) +}) + +test_that("max_branch_lines= and max_branch_expressions= work for a terminal 'else' branch", { + max_lines2_linter <- if_switch_linter(max_branch_lines = 2L) + max_expr2_linter <- if_switch_linter(max_branch_expressions = 2L) + lint_msg <- rex::rex("Prefer repeated if/else statements over overly-complicated switch() statements.") + + else_long_lines <- trim_some(" + if (x == 'a') { + 1 + } else if (x == 'b') { + 2 + } else if (x == 'c') { + 3 + } else { + 4 + 5 + 6 + } + ") + expect_lint(else_long_lines, NULL, max_lines2_linter) + expect_lint(else_long_lines, NULL, max_expr2_linter) + + default_long_lines <- trim_some(" + switch(x, + a = { + 1 + }, + b = { + 2 + }, + c = { + 3 + }, + { + 4 + 5 + 6 + } + ) + ") + expect_lint(default_long_lines, lint_msg, max_lines2_linter) + expect_lint(default_long_lines, lint_msg, max_expr2_linter) +}) + +test_that("max_branch_lines= and max_branch_expressions= are guided by the most complex branch", { + max_lines2_linter <- if_switch_linter(max_branch_lines = 2L) + max_expr2_linter <- if_switch_linter(max_branch_expressions = 2L) + lint_msg <- rex::rex("Prefer repeated if/else statements over overly-complicated switch() statements.") + + # no lint if _any_ branch is too complex + if_else_one_branch_lines <- trim_some(" + if (x == 'a') { + 1 + } else if (x == 'b') { + 2 + } else if (x == 'c') { + 3 + 4 + 5 + } + ") + expect_lint(if_else_one_branch_lines, NULL, max_lines2_linter) + expect_lint(if_else_one_branch_lines, NULL, max_expr2_linter) + + # lint if _any_ branch is too complex + switch_one_branch_lines <- trim_some(" + switch(x, + a = { + 1 + }, + b = { + 2 + }, + c = { + 3 + 4 + 5 + } + ) + ") + expect_lint(switch_one_branch_lines, lint_msg, max_lines2_linter) + expect_lint(switch_one_branch_lines, lint_msg, max_expr2_linter) +}) diff --git a/tests/testthat/test-ifelse_censor_linter.R b/tests/testthat/test-ifelse_censor_linter.R index 85e864b98..581a4081f 100644 --- a/tests/testthat/test-ifelse_censor_linter.R +++ b/tests/testthat/test-ifelse_censor_linter.R @@ -1,54 +1,58 @@ test_that("ifelse_censor_linter skips allowed usages", { - expect_lint("ifelse(x == 2, x, y)", NULL, ifelse_censor_linter()) - expect_lint("ifelse(x > 2, x, y)", NULL, ifelse_censor_linter()) + linter <- ifelse_censor_linter() + + expect_lint("ifelse(x == 2, x, y)", NULL, linter) + expect_lint("ifelse(x > 2, x, y)", NULL, linter) }) test_that("ifelse_censor_linter blocks simple disallowed usages", { + linter <- ifelse_censor_linter() + expect_lint( "ifelse(x < 0, 0, x)", rex::rex("pmax(x, y) is preferable to ifelse(x < y, y, x)"), - ifelse_censor_linter() + linter ) # other equivalents to base::ifelse() expect_lint( "if_else(x < 0, 0, x)", rex::rex("pmax(x, y) is preferable to if_else(x < y, y, x)"), - ifelse_censor_linter() + linter ) expect_lint( "fifelse(x < 0, 0, x)", rex::rex("pmax(x, y) is preferable to fifelse(x < y, y, x)"), - ifelse_censor_linter() + linter ) # other equivalents for censoring expect_lint( "ifelse(x <= 0, 0, x)", rex::rex("pmax(x, y) is preferable to ifelse(x <= y, y, x)"), - ifelse_censor_linter() + linter ) expect_lint( "ifelse(x > 0, x, 0)", rex::rex("pmax(x, y) is preferable to ifelse(x > y, x, y)"), - ifelse_censor_linter() + linter ) expect_lint( "ifelse(x >= 0, x, 0)", rex::rex("pmax(x, y) is preferable to ifelse(x >= y, x, y)"), - ifelse_censor_linter() + linter ) # pairwise min/max (similar to censoring) expect_lint( "ifelse(x < y, x, y)", rex::rex("pmin(x, y) is preferable to ifelse(x < y, x, y)"), - ifelse_censor_linter() + linter ) expect_lint( "ifelse(x >= y, y, x)", rex::rex("pmin(x, y) is preferable to ifelse(x >= y, y, x)"), - ifelse_censor_linter() + linter ) # more complicated expression still matches @@ -60,9 +64,20 @@ test_that("ifelse_censor_linter blocks simple disallowed usages", { expect_lint( lines, rex::rex("pmin(x, y) is preferable to ifelse(x > y, y, x)"), - ifelse_censor_linter() + linter ) }) -# TODO(michaelchirico): how easy would it be to strip parens when considering lint? -# e.g. ifelse(x < (kMaxIndex - 1), x, kMaxIndex - 1) +test_that("lints vectorize", { + expect_lint( + trim_some("{ + ifelse(x >= y, y, x) + ifelse(x >= 0, x, 0) + }"), + list( + list("pmin", line_number = 2L), + list("pmax", line_number = 3L) + ), + ifelse_censor_linter() + ) +}) diff --git a/tests/testthat/test-implicit_assignment_linter.R b/tests/testthat/test-implicit_assignment_linter.R index d8f5e498a..5457cb441 100644 --- a/tests/testthat/test-implicit_assignment_linter.R +++ b/tests/testthat/test-implicit_assignment_linter.R @@ -347,11 +347,11 @@ test_that("implicit_assignment_linter works as expected with pipes and walrus op }) test_that("parenthetical assignments are caught", { - linter <- implicit_assignment_linter() - lint_message <- rex::rex("Avoid implicit assignments in function calls.") - - expect_lint("(x <- 1:10)", lint_message, linter) - expect_lint("if (A && (B <- foo())) { }", lint_message, linter) + expect_lint( + "if (A && (B <- foo())) { }", + rex::rex("Avoid implicit assignments in function calls."), + implicit_assignment_linter() + ) }) test_that("allow_lazy lets lazy assignments through", { @@ -439,7 +439,6 @@ test_that("allow_scoped skips scoped assignments", { ) # outside of branching, doesn't matter - expect_lint("(idx <- foo()); bar()", lint_message, linter) expect_lint("foo(idx <- bar()); baz()", lint_message, linter) expect_lint("foo(x, idx <- bar()); baz()", lint_message, linter) }) @@ -477,3 +476,24 @@ test_that("interaction of allow_lazy and allow_scoped", { linter ) }) + +test_that("call-less '(' mentions avoiding implicit printing", { + linter <- implicit_assignment_linter() + implicit_msg <- rex::rex("Avoid implicit assignments in function calls.") + print_msg <- rex::rex("Call print() explicitly instead of relying on implicit printing behavior via '('.") + + expect_lint("(a <- foo())", print_msg, linter) + + # only for top-level assignments; withAutoprint() ignored + expect_lint("for (xi in x) (z <- foo(xi))", implicit_msg, linter) + + # mixed messages + expect_lint( + trim_some(" + (a <- foo()) + bar(z <- baz(a)) + "), + list(print_msg, implicit_msg), + linter + ) +}) diff --git a/tests/testthat/test-implicit_integer_linter.R b/tests/testthat/test-implicit_integer_linter.R index cd0bebec0..12a94a9b6 100644 --- a/tests/testthat/test-implicit_integer_linter.R +++ b/tests/testthat/test-implicit_integer_linter.R @@ -4,59 +4,58 @@ local({ # Note: cases indicated by "*" are whole numbers, but don't lint because the user has # effectively declared "this is a double" much as adding '.0' is otherwise accepted. cases <- tibble::tribble( - ~num_value_str, ~should_lint, - "Inf", FALSE, - "NaN", FALSE, - "TRUE", FALSE, - "FALSE", FALSE, - "NA", FALSE, - "NA_character_", FALSE, - "2.000", FALSE, - "2.", FALSE, - "2L", FALSE, - "2.0", FALSE, - "2.1", FALSE, - "2", TRUE, - "1e3", TRUE, - "1e3L", FALSE, - "1.0e3L", FALSE, - "1.2e3", FALSE, # * ( = 1200) - "1.2e-3", FALSE, - "1e-3", FALSE, - "1e-33", FALSE, - "1.2e0", FALSE, - "0x1p+0", FALSE, # * ( = 1) - "0x1.ecp+6L", FALSE, - "0x1.ecp+6", FALSE, # * ( = 123) - "0x1.ec66666666666p+6", FALSE, - "8i", FALSE, - "8.0i", FALSE + ~num_value_str, ~lint_msg, + "Inf", "", + "NaN", "", + "TRUE", "", + "FALSE", "", + "NA", "", + "NA_character_", "", + "2.000", "", + "2.", "", + "2L", "", + "2.0", "", + "2.1", "", + "2", "2L or 2.0", + "1e3", "1000L or 1000.0", + "1e3L", "", + "1.0e3L", "", + "1.2e3", "", # * ( = 1200) + "1.2e-3", "", + "1e-3", "", + "1e-33", "", + "1.2e0", "", + "0x1p+0", "", # * ( = 1) + "0x1.ecp+6L", "", + "0x1.ecp+6", "", # * ( = 123) + "0x1.ec66666666666p+6", "", + "8i", "", + "8.0i", "" ) # for convenience of coercing these to string (since tribble doesn't support auto-conversion) int_max <- .Machine[["integer.max"]] # largest number that R can represent as an integer cases_int_max <- tibble::tribble( - ~num_value_str, ~should_lint, - -int_max - 1.0, FALSE, - -int_max, TRUE, - int_max, TRUE, - int_max + 1.0, FALSE + ~num_value_str, ~lint_msg, + -int_max - 1.0, "", + -int_max, sprintf("%1$dL or %1$d.0", -int_max), + int_max, sprintf("%1$dL or %1$d.0", int_max), + int_max + 1.0, "" ) cases_int_max$num_value_str <- as.character(cases_int_max$num_value_str) cases <- rbind(cases, cases_int_max) - cases$.test_name <- sprintf("num_value_str=%s, should_lint=%s", cases$num_value_str, cases$should_lint) linter <- implicit_integer_linter() patrick::with_parameters_test_that( "single numerical constants are properly identified ", - expect_lint(num_value_str, if (should_lint) "Integers should not be implicit", linter), + expect_lint(num_value_str, if (nzchar(lint_msg)) lint_msg, linter), .cases = cases ) }) # styler: on test_that("linter returns the correct linting", { - lint_msg <- "Integers should not be implicit. Use the form 1L for integers or 1.0 for doubles." linter <- implicit_integer_linter() + lint_msg <- rex::rex("Use 1L or 1.0 to avoid implicit integers.") expect_lint("x <<- 1L", NULL, linter) expect_lint("1.0/-Inf -> y", NULL, linter) @@ -67,7 +66,7 @@ test_that("linter returns the correct linting", { ) expect_lint( "z <- 1e5", - list(message = lint_msg, line_number = 1L, column_number = 9L), + list(message = rex::rex("100000L or 100000.0"), line_number = 1L, column_number = 9L), linter ) expect_lint( @@ -78,8 +77,8 @@ test_that("linter returns the correct linting", { expect_lint( "552^9", list( - list(message = lint_msg, line_number = 1L, column_number = 4L), - list(message = lint_msg, line_number = 1L, column_number = 6L) + list(message = rex::rex("552L or 552.0"), line_number = 1L, column_number = 4L), + list(message = rex::rex("9L or 9.0"), line_number = 1L, column_number = 6L) ), linter ) @@ -90,7 +89,7 @@ patrick::with_parameters_test_that( "numbers in a:b input are optionally not linted", expect_lint( paste0(left, ":", right), - if (n_lints > 0L) rep(list("Integers should not be implicit"), n_lints), + if (n_lints > 0L) rep(list(rex::rex("Use 1L or 1.0")), n_lints), implicit_integer_linter(allow_colon = allow_colon) ), .cases = tibble::tribble( diff --git a/tests/testthat/test-infix_spaces_linter.R b/tests/testthat/test-infix_spaces_linter.R index 499cc3e53..ade7969c0 100644 --- a/tests/testthat/test-infix_spaces_linter.R +++ b/tests/testthat/test-infix_spaces_linter.R @@ -124,21 +124,12 @@ test_that("assignment cases return the correct linting", { }) test_that("infix_spaces_linter can allow >1 spaces optionally", { - expect_lint( - "x ~ 1", - rex::rex("Put exactly one space on each side of infix operators."), - infix_spaces_linter(allow_multiple_spaces = FALSE) - ) - expect_lint( - "x - 1", - rex::rex("Put exactly one space on each side of infix operators."), - infix_spaces_linter(allow_multiple_spaces = FALSE) - ) - expect_lint( - "x / 1", - rex::rex("Put exactly one space on each side of infix operators."), - infix_spaces_linter(allow_multiple_spaces = FALSE) - ) + linter <- infix_spaces_linter(allow_multiple_spaces = FALSE) + lint_msg <- rex::rex("Put exactly one space on each side of infix operators.") + + expect_lint("x ~ 1", lint_msg, linter) + expect_lint("x - 1", lint_msg, linter) + expect_lint("x / 1", lint_msg, linter) }) test_that("exception for box::use()", { @@ -223,3 +214,27 @@ test_that("parse tags are accepted by exclude_operators", { expect_lint(text, list(col_assign, col_sub), infix_spaces_linter(exclude_operators = "EQ_FORMALS")) expect_lint(text, list(col_formals, col_sub), infix_spaces_linter(exclude_operators = "EQ_ASSIGN")) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Put spaces around all infix operators.") + + expect_lint( + trim_some("{ + a<-1 + 1/2 + b<-c<-2 + d+e+f+g/3 + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 4L, column_number = 4L), + list(lint_msg, line_number = 4L, column_number = 7L), + list(lint_msg, line_number = 5L, column_number = 4L), + list(lint_msg, line_number = 5L, column_number = 6L), + list(lint_msg, line_number = 5L, column_number = 8L), + list(lint_msg, line_number = 5L, column_number = 10L) + ), + infix_spaces_linter() + ) +}) diff --git a/tests/testthat/test-inner_combine_linter.R b/tests/testthat/test-inner_combine_linter.R index d445dd6d3..2f594374d 100644 --- a/tests/testthat/test-inner_combine_linter.R +++ b/tests/testthat/test-inner_combine_linter.R @@ -89,9 +89,25 @@ patrick::with_parameters_test_that( "present/absent arg (POSIXct)", "c(as.POSIXct(x, format = '%y'), as.POSIXct(y))", "mismatched arg (log)", "c(log(x, base = 4), log(y, base = 5))", "present/absent arg (log)", "c(log(x, base = 4), log(y))" - # TODO(michaelchirico): fix the code so these edge cases are covered + # TODO(#2486): Reactivate these. # "unknown Date method argument", "c(as.Date(x, zoo = zzz), as.Date(y, zoo = zzz))", # "known+unknown Date argument", "c(as.Date(x, format = '%y', zoo = zzz), as.Date(y, format = '%y', zoo = zzz))", # "unknown POSIXct method argument", "c(as.POSIXct(x, zoo = zzz), as.POSIXct(y, zoo = zzz))", ) ) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Combine inputs to vectorized functions first") + + expect_lint( + trim_some("{ + c(sin(x), sin(y)) + c(log(x), log(y)) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + inner_combine_linter() + ) +}) diff --git a/tests/testthat/test-is_numeric_linter.R b/tests/testthat/test-is_numeric_linter.R index 95b2d6957..09052e78a 100644 --- a/tests/testthat/test-is_numeric_linter.R +++ b/tests/testthat/test-is_numeric_linter.R @@ -1,22 +1,26 @@ test_that("is_numeric_linter skips allowed usages involving ||", { - expect_lint("is.numeric(x) || is.integer(y)", NULL, is_numeric_linter()) + linter <- is_numeric_linter() + + expect_lint("is.numeric(x) || is.integer(y)", NULL, linter) # x is used, but not identically - expect_lint("is.numeric(x) || is.integer(foo(x))", NULL, is_numeric_linter()) + expect_lint("is.numeric(x) || is.integer(foo(x))", NULL, linter) # not totally crazy, e.g. if input accepts a vector or a list - expect_lint("is.numeric(x) || is.integer(x[[1]])", NULL, is_numeric_linter()) + expect_lint("is.numeric(x) || is.integer(x[[1]])", NULL, linter) }) test_that("is_numeric_linter skips allowed usages involving %in%", { + linter <- is_numeric_linter() + # false positives for class(x) %in% c('integer', 'numeric') style - expect_lint("class(x) %in% 1:10", NULL, is_numeric_linter()) - expect_lint("class(x) %in% 'numeric'", NULL, is_numeric_linter()) - expect_lint("class(x) %in% c('numeric', 'integer', 'factor')", NULL, is_numeric_linter()) - expect_lint("class(x) %in% c('numeric', 'integer', y)", NULL, is_numeric_linter()) + expect_lint("class(x) %in% 1:10", NULL, linter) + expect_lint("class(x) %in% 'numeric'", NULL, linter) + expect_lint("class(x) %in% c('numeric', 'integer', 'factor')", NULL, linter) + expect_lint("class(x) %in% c('numeric', 'integer', y)", NULL, linter) }) test_that("is_numeric_linter blocks disallowed usages involving ||", { linter <- is_numeric_linter() - lint_msg <- rex::rex("same as is.numeric(x) || is.integer(x)") + lint_msg <- rex::rex("Use `is.numeric(x)` instead of the equivalent `is.numeric(x) || is.integer(x)`.") expect_lint("is.numeric(x) || is.integer(x)", lint_msg, linter) @@ -44,7 +48,7 @@ test_that("is_numeric_linter blocks disallowed usages involving ||", { test_that("is_numeric_linter blocks disallowed usages involving %in%", { linter <- is_numeric_linter() - lint_msg <- rex::rex('same as class(x) %in% c("integer", "numeric")') + lint_msg <- rex::rex('Use is.numeric(x) instead of class(x) %in% c("integer", "numeric")') expect_lint("class(x) %in% c('integer', 'numeric')", lint_msg, linter) expect_lint('class(x) %in% c("numeric", "integer")', lint_msg, linter) @@ -54,7 +58,7 @@ test_that("raw strings are handled properly when testing in class", { skip_if_not_r_version("4.0.0") linter <- is_numeric_linter() - lint_msg <- rex::rex('same as class(x) %in% c("integer", "numeric")') + lint_msg <- rex::rex('Use is.numeric(x) instead of class(x) %in% c("integer", "numeric")') expect_lint("class(x) %in% c(R'(numeric)', 'integer', 'factor')", NULL, linter) expect_lint("class(x) %in% c('numeric', R'--(integer)--', y)", NULL, linter) @@ -62,3 +66,17 @@ test_that("raw strings are handled properly when testing in class", { expect_lint("class(x) %in% c(R'(integer)', 'numeric')", lint_msg, linter) expect_lint('class(x) %in% c("numeric", R"--[integer]--")', lint_msg, linter) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + is.numeric(x) || is.integer(x) + class(x) %in% c('integer', 'numeric') + }"), + list( + list(rex::rex("`is.numeric(x) || is.integer(x)`"), line_number = 2L), + list(rex::rex('class(x) %in% c("integer", "numeric")'), line_number = 3L) + ), + is_numeric_linter() + ) +}) diff --git a/tests/testthat/test-knitr_formats.R b/tests/testthat/test-knitr_formats.R index 7ae3f63f7..a62d23e2a 100644 --- a/tests/testthat/test-knitr_formats.R +++ b/tests/testthat/test-knitr_formats.R @@ -2,8 +2,8 @@ regexes <- list( assign = rex::rex("Use <-, not =, for assignment."), local_var = rex::rex("local variable"), quotes = rex::rex("Only use double-quotes."), - trailing = rex::rex("Trailing blank lines are superfluous."), - trailws = rex::rex("Trailing whitespace is superfluous."), + trailing = rex::rex("Remove trailing blank lines."), + trailws = rex::rex("Remove trailing whitespace."), indent = rex::rex("Indentation should be") ) @@ -94,18 +94,12 @@ test_that("it handles tex", { file = test_path("knitr_formats", "test.Rtex"), checks = list( list(regexes[["indent"]], line_number = 11L), - # TODO(AshesITR): - # masking the Rtex escape char by whitespace causes false-positive indentation lints list(regexes[["assign"]], line_number = 11L), list(regexes[["indent"]], line_number = 22L), list(regexes[["local_var"]], line_number = 23L), list(regexes[["assign"]], line_number = 23L), list(regexes[["trailing"]], line_number = 25L), list(regexes[["trailws"]], line_number = 25L) - # TODO(AshesITR): #1043 - # file_lines contains a whitespace on the final line for Rtex, because that is used to mark the Rtex escape char - # "%" as well. - # cf. get_source_expressions("tests/testthat/knitr_formats/test.Rtex")$lines[[25]] ), linters = default_linters, parse_settings = FALSE diff --git a/tests/testthat/test-length_levels_linter.R b/tests/testthat/test-length_levels_linter.R index eb03d5b1d..c7b07ee18 100644 --- a/tests/testthat/test-length_levels_linter.R +++ b/tests/testthat/test-length_levels_linter.R @@ -9,3 +9,19 @@ test_that("length_levels_linter blocks simple disallowed usages", { length_levels_linter() ) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("nlevels(x) is better than length(levels(x)).") + + expect_lint( + trim_some("{ + length(levels(x)) + length(levels(y)) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + length_levels_linter() + ) +}) diff --git a/tests/testthat/test-length_test_linter.R b/tests/testthat/test-length_test_linter.R index 066873ab5..b60557c12 100644 --- a/tests/testthat/test-length_test_linter.R +++ b/tests/testthat/test-length_test_linter.R @@ -30,3 +30,17 @@ local({ .test_name = names(ops) ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + length(x == y) + length(y == z) + }"), + list( + list(rex::rex("length(x) == y"), line_number = 2L), + list(rex::rex("length(y) == z"), line_number = 3L) + ), + length_test_linter() + ) +}) diff --git a/tests/testthat/test-lengths_linter.R b/tests/testthat/test-lengths_linter.R index 6392698e3..fbca36bd8 100644 --- a/tests/testthat/test-lengths_linter.R +++ b/tests/testthat/test-lengths_linter.R @@ -43,3 +43,19 @@ test_that("lengths_linter blocks simple disallowed usages with pipes", { expect_lint("x |> map_int(length)", lint_msg, linter) expect_lint("x %>% map_int(length)", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Use lengths() to find the length of each element in a list.") + + expect_lint( + trim_some("{ + sapply(x, length) + map_int(x, length) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + lengths_linter() + ) +}) diff --git a/tests/testthat/test-library_call_linter.R b/tests/testthat/test-library_call_linter.R index 46843d528..e7d118906 100644 --- a/tests/testthat/test-library_call_linter.R +++ b/tests/testthat/test-library_call_linter.R @@ -233,6 +233,8 @@ test_that("skips allowed usages of library()/character.only=TRUE", { test_that("blocks disallowed usages of strings in library()/require()", { linter <- library_call_linter() + char_only_msg <- rex::rex("Use symbols in library calls", anything, "character.only") + direct_stub <- "Call library() directly, not vectorized with " expect_lint( 'library("data.table")', @@ -240,43 +242,42 @@ test_that("blocks disallowed usages of strings in library()/require()", { linter ) - expect_lint( - 'library("data.table", character.only = TRUE)', - rex::rex("Use symbols in library calls", anything, "character.only"), - linter - ) - - expect_lint( - 'suppressWarnings(library("data.table", character.only = TRUE))', - rex::rex("Use symbols in library calls", anything, "character.only"), - linter - ) + expect_lint('library("data.table", character.only = TRUE)', char_only_msg, linter) + expect_lint('suppressWarnings(library("data.table", character.only = TRUE))', char_only_msg, linter) expect_lint( "do.call(library, list(data.table))", - rex::rex("Call library() directly, not vectorized with do.call()"), + rex::rex(direct_stub, "do.call()"), linter ) - expect_lint( 'do.call("library", list(data.table))', - rex::rex("Call library() directly, not vectorized with do.call()"), + rex::rex(direct_stub, "do.call()"), linter ) - expect_lint( 'lapply("data.table", library, character.only = TRUE)', - rex::rex("Call library() directly, not vectorized with lapply()"), + rex::rex(direct_stub, "lapply()"), linter ) - expect_lint( 'purr::map("data.table", library, character.only = TRUE)', - rex::rex("Call library() directly, not vectorized with map()"), + rex::rex(direct_stub, "map()"), linter ) }) +test_that("character.only=TRUE is caught in *apply functions passed as strings", { + linter <- library_call_linter() + lib_msg <- rex::rex("Call library() directly, not vectorized with sapply()") + req_msg <- rex::rex("Call require() directly, not vectorized with sapply()") + + expect_lint("sapply(pkgs, 'library', character.only = TRUE)", lib_msg, linter) + expect_lint('sapply(pkgs, "library", character.only = TRUE)', lib_msg, linter) + expect_lint("sapply(pkgs, 'require', character.only = TRUE)", req_msg, linter) + expect_lint('sapply(pkgs, "require", character.only = TRUE)', req_msg, linter) +}) + test_that("character.only=TRUE is caught with multiple-line source", { expect_lint( trim_some(' @@ -330,20 +331,26 @@ patrick::with_parameters_test_that( expect_lint(sprintf("%1$s(x); y; %1$s(z)", call), NULL, linter) # inline or potentially with gaps don't matter - lines <- c( - sprintf("%s(x)", call), - "y", - "", - "stopifnot(z)" + expect_lint( + trim_some(glue::glue(" + {call}(x) + y + + stopifnot(z) + ")), + NULL, + linter ) - expect_lint(lines, NULL, linter) # only suppressing calls with library() - lines_consecutive <- c( - sprintf("%s(x)", call), - sprintf("%s(y)", call) + expect_lint( + trim_some(glue::glue(" + {call}(x) + {call}(y) + ")), + NULL, + linter ) - expect_lint(lines_consecutive, NULL, linter) }, .test_name = c("suppressMessages", "suppressPackageStartupMessages"), call = c("suppressMessages", "suppressPackageStartupMessages") @@ -358,25 +365,34 @@ patrick::with_parameters_test_that( # one test of inline usage expect_lint(sprintf("%1$s(library(x)); %1$s(library(y))", call), message, linter) - lines_gap <- c( - sprintf("%s(library(x))", call), - "", - sprintf("%s(library(y))", call) + expect_lint( + trim_some(glue::glue(" + {call}(library(x)) + + {call}(library(y)) + ")), + message, + linter ) - expect_lint(lines_gap, message, linter) - lines_consecutive <- c( - sprintf("%s(require(x))", call), - sprintf("%s(require(y))", call) + expect_lint( + trim_some(glue::glue(" + {call}(require(x)) + {call}(require(y)) + ")), + message, + linter ) - expect_lint(lines_consecutive, message, linter) - lines_comment <- c( - sprintf("%s(library(x))", call), - "# a comment on y", - sprintf("%s(library(y))", call) + expect_lint( + trim_some(glue::glue(" + {call}(library(x)) + # a comment on y + {call}(library(y)) + ")), + message, + linter ) - expect_lint(lines_comment, message, linter) }, .test_name = c("suppressMessages", "suppressPackageStartupMessages"), call = c("suppressMessages", "suppressPackageStartupMessages") diff --git a/tests/testthat/test-line_length_linter.R b/tests/testthat/test-line_length_linter.R index a098ba14c..5e22fc523 100644 --- a/tests/testthat/test-line_length_linter.R +++ b/tests/testthat/test-line_length_linter.R @@ -23,10 +23,12 @@ test_that("line_length_linter blocks disallowed usages", { list( list( message = lint_msg, + line_number = 1L, column_number = 81L ), list( message = lint_msg, + line_number = 2L, column_number = 81L ) ), @@ -62,7 +64,10 @@ test_that("Multiple lints give custom messages", { abcdefg hijklmnop }"), - list("9 characters", "11 characters"), + list( + list("9 characters", line_number = 2L), + list("11 characters", line_number = 3L) + ), line_length_linter(5L) ) }) diff --git a/tests/testthat/test-lint.R b/tests/testthat/test-lint.R index 05337c8d8..1369360bf 100644 --- a/tests/testthat/test-lint.R +++ b/tests/testthat/test-lint.R @@ -105,7 +105,12 @@ test_that("lint() results do not depend on the position of the .lintr", { }) test_that("lint uses linter names", { - expect_lint("a = 2", list(linter = "bla"), linters = list(bla = assignment_linter()), parse_settings = FALSE) + expect_lint( + "a = 2", + list(linter = "bla"), + linters = list(bla = assignment_linter()), + parse_settings = FALSE + ) }) test_that("lint() results from file or text should be consistent", { diff --git a/tests/testthat/test-lint_package.R b/tests/testthat/test-lint_package.R index 957b8af9c..f0d2c0c48 100644 --- a/tests/testthat/test-lint_package.R +++ b/tests/testthat/test-lint_package.R @@ -231,6 +231,9 @@ test_that("package using .lintr.R config lints correctly", { }) test_that("lintr need not be attached for .lintr.R configs to use lintr functions", { + # For some obscure reason, running in the subprocess on this specific version of R + # on Windows stopped working after PR #2446 with 'Package lintr not found'. + if (getRversion() == "3.6.3") skip_on_os("windows") exprs <- paste( 'options(lintr.linter_file = "lintr_test_config")', sprintf('lints <- lintr::lint_package("%s")', test_path("dummy_packages", "RConfig")), diff --git a/tests/testthat/test-literal_coercion_linter.R b/tests/testthat/test-literal_coercion_linter.R index 3605f700a..247416a2c 100644 --- a/tests/testthat/test-literal_coercion_linter.R +++ b/tests/testthat/test-literal_coercion_linter.R @@ -70,10 +70,13 @@ patrick::with_parameters_test_that( skip_if_not_installed("rlang") test_that("multiple lints return custom messages", { expect_lint( - "c(as.integer(1), lgl(1L))", + trim_some("{ + as.integer(1) + lgl(1L) + }"), list( - rex::rex("Use 1L instead of as.integer(1)"), - rex::rex("Use TRUE instead of lgl(1L)") + list(rex::rex("Use 1L instead of as.integer(1)"), line_number = 2L), + list(rex::rex("Use TRUE instead of lgl(1L)"), line_number = 3L) ), literal_coercion_linter() ) diff --git a/tests/testthat/test-matrix_apply_linter.R b/tests/testthat/test-matrix_apply_linter.R index 76d07efdd..0a30b3ce1 100644 --- a/tests/testthat/test-matrix_apply_linter.R +++ b/tests/testthat/test-matrix_apply_linter.R @@ -87,13 +87,13 @@ test_that("matrix_apply_linter works with multiple lints in a single expression" linter <- matrix_apply_linter() expect_lint( - "rbind( - apply(x, 1, sum), + trim_some("{ + apply(x, 1, sum) apply(y, 2:4, mean, na.rm = TRUE) - )", + }"), list( - rex::rex("Use rowSums(x)"), - rex::rex("Use rowMeans(colMeans(y, na.rm = TRUE), dims = 3) or colMeans(y, na.rm = TRUE) if y has 4 dimensions") + list(rex::rex("rowSums(x)"), line_number = 2L), + list(rex::rex("rowMeans(colMeans(y, na.rm = TRUE), dims = 3)"), line_number = 3L) ), linter ) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index a79ac7591..9f454c1f4 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -98,8 +98,6 @@ test_that("print.lint works", { }) test_that("print.lint works for inline data, even in RStudio", { - skip_if_not_installed("mockery") - l <- lint("x = 1\n") # Make sure lints print to console. @@ -114,7 +112,11 @@ test_that("print.lint works for inline data, even in RStudio", { expect_output(print(l), "not =") ) - mockery::stub(print.lints, "rstudioapi::hasFun", function(...) FALSE) + skip_if_not_installed("rstudioapi") + local_mocked_bindings( + hasFun = function(...) FALSE, + .package = "rstudioapi" + ) withr::with_options( list(lintr.rstudio_source_markers = TRUE), expect_output(print(l), "not =") @@ -170,6 +172,22 @@ local({ lints <- lint(text = "a", linters = test_linter()) lint <- lints[[1L]] + widths <- c(10L, 20L, 40L, 80L) + test_names <- paste0(": width = ", widths) + + patrick::with_parameters_test_that( + "print.lint, print.lints support optional message wrapping", + { + expect_snapshot(print(lints, width = width)) + + withr::with_options(c(lintr.format_width = width), { + expect_snapshot(print(lints)) + }) + }, + .test_name = test_names, + width = widths + ) + wrapped_strings <- c( "[test_linter]\n The\n quick\n brown\n fox\n jumps\n over\n the\n lazy\n dog.", "[test_linter]\n The quick brown\n fox jumps over\n the lazy dog.", @@ -178,22 +196,18 @@ local({ ) patrick::with_parameters_test_that( - "format.lint, format.lints, print.lint, print.lints support optional message wrapping", + "format.lint, format.lints support optional message wrapping", { expect_match(format(lint, width = width), wrapped_string, fixed = TRUE) expect_match(format(lints, width = width), wrapped_string, fixed = TRUE) - expect_output(print(lint, width = width), wrapped_string, fixed = TRUE) - expect_output(print(lints, width = width), wrapped_string, fixed = TRUE) withr::with_options(c(lintr.format_width = width), { expect_match(format(lint), wrapped_string, fixed = TRUE) expect_match(format(lints), wrapped_string, fixed = TRUE) - expect_output(print(lint), wrapped_string, fixed = TRUE) - expect_output(print(lints), wrapped_string, fixed = TRUE) }) }, - .test_name = c(10L, 20L, 40L, 80L), - width = c(10L, 20L, 40L, 80L), + .test_name = test_names, + width = widths, wrapped_string = wrapped_strings ) }) diff --git a/tests/testthat/test-missing_argument_linter.R b/tests/testthat/test-missing_argument_linter.R index 48dba5093..f74bbd56d 100644 --- a/tests/testthat/test-missing_argument_linter.R +++ b/tests/testthat/test-missing_argument_linter.R @@ -10,19 +10,29 @@ test_that("missing_argument_linter skips allowed usages", { expect_lint("alist(a =, b =, c = 1, 0)", NULL, linter) expect_lint("pairlist(path = quote(expr = ))", NULL, linter) #1889 + # always allow this missing usage + expect_lint("foo()", NULL, linter) + expect_lint("test(a =, b =, c = 1, 0)", NULL, missing_argument_linter("test")) }) test_that("missing_argument_linter blocks disallowed usages", { linter <- missing_argument_linter() - lint_msg <- rex::rex("Missing argument in function call.") + lint_msg1 <- rex::rex("Missing argument 1 in function call.") + lint_msg2 <- rex::rex("Missing argument 2 in function call.") + lint_msg3 <- rex::rex("Missing argument 3 in function call.") + lint_msga <- rex::rex("Missing argument 'a' in function call.") - expect_lint("fun(, a = 1)", list(message = lint_msg), linter) - expect_lint("f <- function(x, y) x\nf(, y = 1)\n", list(line = "f(, y = 1)"), linter) - expect_lint("fun(a = 1,, b = 2)", list(message = lint_msg), linter) - expect_lint("fun(a = 1, b =)", list(message = lint_msg), linter) - expect_lint("fun(a = 1,)", list(message = lint_msg), linter) - expect_lint("fun(a = )", list(message = lint_msg), linter) + expect_lint("fun(, a = 1)", lint_msg1, linter) + expect_lint( + "f <- function(x, y) x\nf(, y = 1)\n", + list(lint_msg1, line = "f(, y = 1)"), + linter + ) + expect_lint("fun(a = 1,, b = 2)", lint_msg2, linter) + expect_lint("fun(b = 1, a =)", lint_msga, linter) + expect_lint("fun(a = 1,)", lint_msg2, linter) + expect_lint("fun(a = )", lint_msga, linter) expect_lint( trim_some(" @@ -31,35 +41,12 @@ test_that("missing_argument_linter blocks disallowed usages", { b = 2, ) "), - list(message = lint_msg), + lint_msg3, linter ) - expect_lint("stats::median(1:10, na.rm =)", list(message = lint_msg), linter) - expect_lint("env$get(1:10, default =)", list(message = lint_msg), linter) - - # except list can be empty - expect_lint("switch(a =, b = 1, 0)", list(message = lint_msg), missing_argument_linter(character())) - expect_lint("alist(a =)", list(message = lint_msg), missing_argument_linter(character())) - - # allow_trailing can allow trailing empty args also for non-excepted functions - expect_lint("fun(a = 1,)", NULL, missing_argument_linter(allow_trailing = TRUE)) - expect_lint( - trim_some(" - fun( - a = 1, - # comment - ) - "), - NULL, - missing_argument_linter(allow_trailing = TRUE) - ) - # ... but not if the final argument is named - expect_lint( - "fun(a = 1, b = )", - list(message = lint_msg), - missing_argument_linter(allow_trailing = TRUE) - ) + expect_lint("stats::median(1:10, a =)", lint_msga, linter) + expect_lint("env$get(1:10, a =)", lint_msga, linter) # Fixes https://github.com/r-lib/lintr/issues/906 # Comments should be ignored so that missing arguments could be @@ -72,7 +59,7 @@ test_that("missing_argument_linter blocks disallowed usages", { # comment ) "), - list(message = lint_msg), + lint_msg3, linter ) @@ -84,7 +71,7 @@ test_that("missing_argument_linter blocks disallowed usages", { 1 ) "), - list(message = lint_msg), + lint_msg1, linter ) @@ -96,7 +83,99 @@ test_that("missing_argument_linter blocks disallowed usages", { 1 ) "), - list(message = lint_msg), + lint_msga, linter ) }) + +test_that("except list can be empty", { + linter <- missing_argument_linter(character()) + lint_msg <- rex::rex("Missing argument 'a' in function call.") + + expect_lint("switch(a =, b = 1, 0)", lint_msg, linter) + expect_lint("alist(a =)", lint_msg, linter) +}) + +test_that("allow_trailing can allow trailing empty args also for non-excepted functions", { + linter <- missing_argument_linter(allow_trailing = TRUE) + + expect_lint("fun(a = 1,)", NULL, linter) + expect_lint( + trim_some(" + fun( + a = 1, + # comment + ) + "), + NULL, + linter + ) + # ... but not if the final argument is named + expect_lint( + "fun(a = 1, b = )", + rex::rex("Missing argument 'b' in function call."), + linter + ) +}) + +test_that("lints vectorize", { + linter <- missing_argument_linter() + linter_trailing <- missing_argument_linter(allow_trailing = TRUE) + lint_msg <- rex::rex("Missing argument in function call.") + + expect_lint( + "foo(,,)", + list( + list("Missing argument 1", column_number = 5L), + list("Missing argument 2", column_number = 6L), + list("Missing argument 3", column_number = 7L) + ), + linter + ) + expect_lint( + "foo(,,)", + list( + list("Missing argument 1", column_number = 5L), + list("Missing argument 2", column_number = 6L) + ), + linter_trailing + ) + + expect_lint( + "foo(a =,,)", + list( + list("Missing argument 'a'", column_number = 7L), + list("Missing argument 2", column_number = 9L), + list("Missing argument 3", column_number = 10L) + ), + linter + ) + expect_lint( + "foo(a =,,)", + list( + list("Missing argument 'a'", column_number = 7L), + list("Missing argument 2", column_number = 9L) + ), + linter_trailing + ) + + expect_lint( + trim_some("{ + foo(1,) + bar(,2) + }"), + list( + list("Missing argument 2", line_number = 2L), + list("Missing argument 1", line_number = 3L) + ), + linter + ) + expect_lint( + trim_some("{ + foo(1,) + bar(,2) + }"), + list("Missing argument 1", line_number = 3L), + linter_trailing + ) +}) diff --git a/tests/testthat/test-missing_package_linter.R b/tests/testthat/test-missing_package_linter.R index f2d27ca97..4b0d0165f 100644 --- a/tests/testthat/test-missing_package_linter.R +++ b/tests/testthat/test-missing_package_linter.R @@ -1,6 +1,5 @@ test_that("missing_package_linter skips allowed usages", { linter <- missing_package_linter() - lint_msg <- list(message = rex::rex("Package 'statts' is not installed.")) expect_lint("library(stats)", NULL, linter) expect_lint('library("stats")', NULL, linter) @@ -16,7 +15,7 @@ test_that("missing_package_linter skips allowed usages", { test_that("missing_package_linter blocks disallowed usages", { linter <- missing_package_linter() - lint_msg <- list(message = rex::rex("Package 'statts' is not installed.")) + lint_msg <- rex::rex("Package 'statts' is not installed.") expect_lint("require(statts)", lint_msg, linter) expect_lint("library(statts, quietly = TRUE)", lint_msg, linter) @@ -29,20 +28,24 @@ test_that("missing_package_linter blocks disallowed usages", { library(utils) library(statts) "), - list(line = "library(statts)"), + list(lint_msg, line_number = 2L, line = "library(statts)"), linter ) }) test_that("loadNamespace and requireNamespace allow plain symbols", { - expect_lint("loadNamespace(mypkg)", NULL, missing_package_linter()) - expect_lint("requireNamespace(mypkg)", NULL, missing_package_linter()) + linter <- missing_package_linter() + + expect_lint("loadNamespace(mypkg)", NULL, linter) + expect_lint("requireNamespace(mypkg)", NULL, linter) }) test_that("character.only=TRUE case is handled", { - expect_lint("library(statts, character.only = TRUE)", NULL, missing_package_linter()) - expect_lint("require(statts, character.only = TRUE)", NULL, missing_package_linter()) - expect_lint('library("stats", character.only = TRUE)', NULL, missing_package_linter()) + linter <- missing_package_linter() + + expect_lint("library(statts, character.only = TRUE)", NULL, linter) + expect_lint("require(statts, character.only = TRUE)", NULL, linter) + expect_lint('library("stats", character.only = TRUE)', NULL, linter) expect_lint( 'library("statts", character.only = TRUE)', diff --git a/tests/testthat/test-namespace_linter.R b/tests/testthat/test-namespace_linter.R index fd3686fc8..081e38b21 100644 --- a/tests/testthat/test-namespace_linter.R +++ b/tests/testthat/test-namespace_linter.R @@ -40,37 +40,56 @@ test_that("namespace_linter blocks disallowed usages", { expect_lint( "statts::sd(c(1,2,3))", - list(message = rex::rex("Package 'statts' is not installed.")), + rex::rex("Package 'statts' is not installed."), linter ) expect_lint( "stats::ssd(c(1,2,3))", - list(message = rex::rex("'ssd' is not exported from {stats}")), + rex::rex("'ssd' is not exported from {stats}"), linter ) expect_lint( "stats:::sd(c(1,2,3))", - list(message = rex::rex("'sd' is exported from {stats}. Use stats::sd instead.")), + rex::rex("Don't use `:::` to access sd, which is exported from stats."), linter ) expect_lint( "statts:::sd(c(1,2,3))", - list(message = rex::rex("Package 'statts' is not installed.")), + rex::rex("Package 'statts' is not installed."), linter ) expect_lint( "stats:::sdd(c(1,2,3))", - list(message = rex::rex("'sdd' does not exist in {stats}")), + rex::rex("'sdd' does not exist in {stats}"), linter ) expect_lint( - "stats::sd(c(1,2,3))\nstats::sdd(c(1,2,3))", + trim_some(" + stats::sd(c(1,2,3)) + stats::sdd(c(1,2,3)) + "), list(line = "stats::sdd(c(1,2,3))"), linter ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + statts::sd(c(1,2,3)) + stats::ssd(c(1,2,3)) + stats:::sd(c(1,2,3)) + }"), + list( + list(rex::rex("Package 'statts' is not installed."), line_number = 2L), + list(rex::rex("'ssd' is not exported from {stats}"), line_number = 3L), + list(rex::rex("Don't use `:::` to access sd"), line_number = 4L) + ), + namespace_linter() + ) +}) diff --git a/tests/testthat/test-nested_ifelse_linter.R b/tests/testthat/test-nested_ifelse_linter.R index 14bd3302f..66e6d1ff6 100644 --- a/tests/testthat/test-nested_ifelse_linter.R +++ b/tests/testthat/test-nested_ifelse_linter.R @@ -59,3 +59,17 @@ test_that("nested_ifelse_linter also catches data.table::fifelse", { nested_ifelse_linter() ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + ifelse(x < 0, ifelse(x == 0, 0, 1), -1) + fifelse(y < 0, fifelse(y == 0, 0, 1), -1) + }"), + list( + list("ifelse", line_number = 2L), + list("fifelse", line_number = 3L) + ), + nested_ifelse_linter() + ) +}) diff --git a/tests/testthat/test-nonportable_path_linter.R b/tests/testthat/test-nonportable_path_linter.R index 9ba27f1c2..9069ff938 100644 --- a/tests/testthat/test-nonportable_path_linter.R +++ b/tests/testthat/test-nonportable_path_linter.R @@ -57,3 +57,19 @@ test_that("nonportable_path_linter's lax argument works", { expect_lint(double_quote(path), NULL, linter) } }) + +test_that("lints vectorize", { + lint_msg <- rex::escape("Use file.path() to construct portable file paths.") + + expect_lint( + trim_some("{ + '~/' + 'C:/' + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + nonportable_path_linter(lax = FALSE) + ) +}) diff --git a/tests/testthat/test-nrow_subset_linter.R b/tests/testthat/test-nrow_subset_linter.R index 18a3e45d8..8f1d49f24 100644 --- a/tests/testthat/test-nrow_subset_linter.R +++ b/tests/testthat/test-nrow_subset_linter.R @@ -13,6 +13,14 @@ test_that("nrow_subset_linter blocks subset() cases", { ) }) +test_that("nrow_subset_linter blocks filter() cases", { + expect_lint( + "nrow(filter(x, y == z))", + rex::rex("Use arithmetic to count the number of rows satisfying a condition"), + nrow_subset_linter() + ) +}) + test_that("lints vectorize", { lint_msg <- rex::rex("Use arithmetic to count the number of rows satisfying a condition") @@ -21,11 +29,24 @@ test_that("lints vectorize", { nrow(subset(x, y == z)) subset(x) %>% transform(m = 2) nrow(subset(a, b == c)) + x %>% filter(y == z) %>% nrow() }"), list( list(lint_msg, line_number = 2L), - list(lint_msg, line_number = 4L) + list(lint_msg, line_number = 4L), + list(lint_msg, line_number = 5L) ), nrow_subset_linter() ) }) + +test_that("linter is pipeline-aware", { + linter <- nrow_subset_linter() + lint_msg <- "Use arithmetic to count the number of rows satisfying a condition" + + expect_lint("x %>% subset(y == z) %>% nrow()", lint_msg, linter) + expect_lint("filter(x, y == z) %>% nrow()", lint_msg, linter) + + skip_if_not_r_version("4.1.0") + expect_lint("x |> subset(y == z) |> nrow()", lint_msg, linter) +}) diff --git a/tests/testthat/test-numeric_leading_zero_linter.R b/tests/testthat/test-numeric_leading_zero_linter.R index b90cbe05d..3f362bc3a 100644 --- a/tests/testthat/test-numeric_leading_zero_linter.R +++ b/tests/testthat/test-numeric_leading_zero_linter.R @@ -25,3 +25,19 @@ test_that("numeric_leading_zero_linter blocks simple disallowed usages", { expect_lint("d <- 6.7+.8i", lint_msg, linter) expect_lint("e <- .9e10", lint_msg, linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Include the leading zero for fractional numeric constants.") + + expect_lint( + trim_some("{ + .1 + -.2 + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + numeric_leading_zero_linter() + ) +}) diff --git a/tests/testthat/test-nzchar_linter.R b/tests/testthat/test-nzchar_linter.R index 4a3c65dca..afb1d2744 100644 --- a/tests/testthat/test-nzchar_linter.R +++ b/tests/testthat/test-nzchar_linter.R @@ -17,34 +17,31 @@ test_that("nzchar_linter skips as appropriate for other nchar args", { # type="bytes" should be >= the value for the default (type="chars") expect_lint("nchar(x, type='width') == 0L", NULL, linter) - # TODO(michaelchirico): check compatibility of nchar(., allowNA=TRUE). - # there are no examples in ?nchar, nor any relevant usages on StackOverflow. - # just assume they are incompatible now to be conservative. expect_lint("nchar(x, allowNA=TRUE) == 0L", NULL, linter) # nzchar also has keepNA argument so a drop-in switch is easy expect_lint( "nchar(x, keepNA=TRUE) == 0", - rex::rex("Instead of comparing nchar(x) to 0"), + rex::rex("Use !nzchar(x) instead of nchar(x) == 0"), linter ) }) test_that("nzchar_linter blocks simple disallowed usages", { linter <- nzchar_linter() - lint_msg_quote <- rex::rex('Instead of comparing strings to "", use nzchar()') - lint_msg_nchar <- rex::rex("Instead of comparing nchar(x) to 0") + lint_msg_quote <- rex::rex('Use !nzchar(x) instead of x == ""') + lint_msg_nchar <- rex::rex("Use nzchar() instead of comparing nchar(x) to 0") expect_lint("which(x == '')", lint_msg_quote, linter) - expect_lint("any(nchar(x) >= 0)", lint_msg_nchar, linter) - expect_lint("all(nchar(x) == 0L)", lint_msg_nchar, linter) - expect_lint("sum(0.0 < nchar(x))", lint_msg_nchar, linter) + expect_lint("any(nchar(x) >= 0)", rex::rex("nchar(x) >= 0 is always true, maybe you want nzchar(x)?"), linter) + expect_lint("all(nchar(x) == 0L)", rex::rex("Use !nzchar(x) instead of nchar(x) == 0"), linter) + expect_lint("sum(0.0 < nchar(x))", rex::rex("Use nzchar(x) instead of nchar(x) > 0"), linter) }) test_that("nzchar_linter skips comparison to '' in if/while statements", { linter <- nzchar_linter() - lint_msg_quote <- rex::rex('Instead of comparing strings to "", use nzchar()') - lint_msg_nchar <- rex::rex("Instead of comparing nchar(x) to 0") + lint_msg_quote <- rex::rex('Use !nzchar(x) instead of x == ""') + lint_msg_nchar <- rex::rex("Use nzchar(x) instead of nchar(x) > 0") # still lint nchar() comparisons expect_lint("if (nchar(x) > 0) TRUE", lint_msg_nchar, linter) @@ -63,11 +60,15 @@ test_that("multiple lints are generated correctly", { expect_lint( trim_some("{ a == '' - nchar(b) != 0 + '' < b + nchar(c) != 0 + 0.0 > nchar(d) }"), list( - list(rex::rex('Instead of comparing strings to ""'), line_number = 2L), - list(rex::rex("Instead of comparing nchar(x) to 0"), line_number = 3L) + list(rex::rex('Use !nzchar(x) instead of x == ""'), line_number = 2L), + list(rex::rex('Use nzchar(x) instead of x > ""'), line_number = 3L), + list(rex::rex("Use nzchar(x) instead of nchar(x) != 0."), line_number = 4L), + list(rex::rex("nchar(x) < 0 is always false, maybe you want !nzchar(x)?"), line_number = 5L) ), nzchar_linter() ) diff --git a/tests/testthat/test-object_name_linter.R b/tests/testthat/test-object_name_linter.R index 7a0154561..97f0022ca 100644 --- a/tests/testthat/test-object_name_linter.R +++ b/tests/testthat/test-object_name_linter.R @@ -96,7 +96,7 @@ test_that("linter accepts vector of styles", { linter <- object_name_linter(styles = c("camelCase", "dotted.case")) expect_lint( - c("var.one <- 1", "varTwo <- 2", "var_three <- 3"), + "var.one <- 1\nvarTwo <- 2\nvar_three <- 3", list(message = lint_msg, line_number = 3L, column_number = 1L), linter ) diff --git a/tests/testthat/test-one_call_pipe_linter.R b/tests/testthat/test-one_call_pipe_linter.R index a24f3380b..9a1a84975 100644 --- a/tests/testthat/test-one_call_pipe_linter.R +++ b/tests/testthat/test-one_call_pipe_linter.R @@ -14,22 +14,20 @@ test_that("one_call_pipe_linter skips allowed usages", { test_that("one_call_pipe_linter blocks simple disallowed usages", { linter <- one_call_pipe_linter() - lint_msg <- rex::rex("Expressions with only a single call shouldn't use pipe %>%.") + lint_msg <- rex::rex("Avoid pipe %>% for expressions with only a single call.") expect_lint("x %>% foo()", lint_msg, linter) # new lines don't matter expect_lint("x %>%\n foo()", lint_msg, linter) - # catch the "inner" pipe chain, not the "outer" one - # TODO(michaelchirico): actually, this should lint twice -- we're too aggressive - # in counting _all_ nested calls. + # nested case expect_lint("x %>% inner_join(y %>% filter(is_treatment))", lint_msg, linter) }) test_that("one_call_pipe_linter skips data.table chains", { linter <- one_call_pipe_linter() - lint_msg <- rex::rex("Expressions with only a single call shouldn't use pipe %>%.") + lint_msg <- rex::rex("Avoid pipe %>% for expressions with only a single call.") expect_lint("DT[x > 5, sum(y), by = keys] %>% .[, .SD[1], by = key1]", NULL, linter) @@ -44,11 +42,11 @@ test_that("one_call_pipe_linter skips data.table chains", { test_that("one_call_pipe_linter treats all pipes equally", { linter <- one_call_pipe_linter() - lint_msg_part <- "Expressions with only a single call shouldn't use pipe " + lint_msg_part <- " for expressions with only a single call." expect_lint("foo %>% bar() %$% col", NULL, linter) - expect_lint("x %T>% foo()", rex::rex(lint_msg_part, "%T>%."), linter) - expect_lint("x %$%\n foo", rex::rex(lint_msg_part, "%$%."), linter) + expect_lint("x %T>% foo()", rex::rex("%T>%", lint_msg_part), linter) + expect_lint("x %$%\n foo", rex::rex("%$%", lint_msg_part), linter) expect_lint( 'data %>% filter(type == "console") %$% obscured_id %>% unique()', NULL, @@ -80,7 +78,7 @@ test_that("Native pipes are handled as well", { expect_lint( "x |> foo()", - rex::rex("Expressions with only a single call shouldn't use pipe |>."), + rex::rex("Avoid pipe |> for expressions with only a single call."), linter ) @@ -105,7 +103,7 @@ test_that("one_call_pipe_linter skips data.table chains with native pipe", { skip_if_not_r_version("4.3.0") linter <- one_call_pipe_linter() - lint_msg <- rex::rex("Expressions with only a single call shouldn't use pipe |>.") + lint_msg <- rex::rex("Avoid pipe |> for expressions with only a single call.") expect_lint("DT[x > 5, sum(y), by = keys] |> _[, .SD[1], by = key1]", NULL, linter) diff --git a/tests/testthat/test-outer_negation_linter.R b/tests/testthat/test-outer_negation_linter.R index acf2e3df3..0601aa4ee 100644 --- a/tests/testthat/test-outer_negation_linter.R +++ b/tests/testthat/test-outer_negation_linter.R @@ -19,50 +19,39 @@ test_that("outer_negation_linter skips allowed usages", { test_that("outer_negation_linter blocks simple disallowed usages", { linter <- outer_negation_linter() + not_all_msg <- rex::rex("!all(x) is better than any(!x)") + not_any_msg <- rex::rex("!any(x) is better than all(!x)") - expect_lint( - "any(!x)", - rex::rex("!all(x) is better than any(!x)"), - linter - ) - - expect_lint( - "all(!foo(x))", - rex::rex("!any(x) is better than all(!x)"), - linter - ) - + expect_lint("any(!x)", not_all_msg, linter) + expect_lint("all(!foo(x))", not_any_msg, linter) # na.rm doesn't change the recommendation - expect_lint( - "any(!x, na.rm = TRUE)", - rex::rex("!all(x) is better than any(!x)"), - linter - ) - + expect_lint("any(!x, na.rm = TRUE)", not_all_msg, linter) # also catch nested usage - expect_lint( - "all(!(x + y))", - rex::rex("!any(x) is better than all(!x)"), - linter - ) - + expect_lint("all(!(x + y))", not_any_msg, linter) # catch when all inputs are negated - expect_lint( - "any(!x, !y)", - rex::rex("!all(x) is better than any(!x)"), - linter - ) - - expect_lint( - "all(!x, !y, na.rm = TRUE)", - rex::rex("!any(x) is better than all(!x)"), - linter - ) + expect_lint("any(!x, !y)", not_all_msg, linter) + expect_lint("all(!x, !y, na.rm = TRUE)", not_any_msg, linter) }) test_that("outer_negation_linter doesn't trigger on empty calls", { + linter <- outer_negation_linter() + # minimal version of issue - expect_lint("any()", NULL, outer_negation_linter()) + expect_lint("any()", NULL, linter) # closer to what was is practically relevant, as another regression test - expect_lint("x %>% any()", NULL, outer_negation_linter()) + expect_lint("x %>% any()", NULL, linter) +}) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + any(!x) + all(!y) + }"), + list( + list(rex::rex("!all(x)"), line_number = 2L), + list(rex::rex("!any(x)"), line_number = 3L) + ), + outer_negation_linter() + ) }) diff --git a/tests/testthat/test-package_hooks_linter.R b/tests/testthat/test-package_hooks_linter.R index 369ddbcbd..883a1b0fd 100644 --- a/tests/testthat/test-package_hooks_linter.R +++ b/tests/testthat/test-package_hooks_linter.R @@ -1,25 +1,20 @@ test_that("package_hooks_linter skips allowed usages of packageStartupMessage() & library.dynam()", { - # allowed in .onAttach, not .onLoad - expect_lint( - ".onAttach <- function(lib, pkg) packageStartupMessage('hi')", - NULL, - package_hooks_linter() - ) + linter <- package_hooks_linter() + # allowed in .onAttach, not .onLoad + expect_lint(".onAttach <- function(lib, pkg) packageStartupMessage('hi')", NULL, linter) # allowed in .onLoad, not .onAttach - expect_lint( - ".onLoad <- function(lib, pkg) library.dynam()", - NULL, - package_hooks_linter() - ) + expect_lint(".onLoad <- function(lib, pkg) library.dynam()", NULL, linter) }) test_that("package_hooks_linter blocks simple disallowed usages of packageStartupMessage() & library.dynam()", { + linter <- package_hooks_linter() + # inline version expect_lint( ".onLoad <- function(lib, pkg) packageStartupMessage('hi')", rex::rex("Put packageStartupMessage() calls in .onAttach()"), - package_hooks_linter() + linter ) # multiline version @@ -30,7 +25,7 @@ test_that("package_hooks_linter blocks simple disallowed usages of packageStartu } "), rex::rex("Put library.dynam() calls in .onLoad, not .onAttach()."), - package_hooks_linter() + linter ) # found at deeper nesting too @@ -41,16 +36,18 @@ test_that("package_hooks_linter blocks simple disallowed usages of packageStartu } "), rex::rex("Put packageStartupMessage() calls in .onAttach()"), - package_hooks_linter() + linter ) }) test_that("package_hooks_linter blocks simple disallowed usages of other blocked messaging functions", { + linter <- package_hooks_linter() + # inline version expect_lint( ".onLoad <- function(lib, pkg) cat('hi')", rex::rex("Don't use cat() in .onLoad()"), - package_hooks_linter() + linter ) # multiline version @@ -61,7 +58,7 @@ test_that("package_hooks_linter blocks simple disallowed usages of other blocked } "), rex::rex("Don't use writeLines() in .onAttach()"), - package_hooks_linter() + linter ) expect_lint( @@ -71,7 +68,7 @@ test_that("package_hooks_linter blocks simple disallowed usages of other blocked } "), rex::rex("Don't use print() in .onLoad()"), - package_hooks_linter() + linter ) # found at deeper nesting too @@ -82,168 +79,160 @@ test_that("package_hooks_linter blocks simple disallowed usages of other blocked } "), rex::rex("Don't use message() in .onAttach()"), - package_hooks_linter() + linter ) }) test_that("package_hooks_linter skips valid .onLoad() and .onAttach() arguments", { - expect_lint(".onAttach <- function(lib, pkg) { }", NULL, package_hooks_linter()) - expect_lint(".onLoad <- function(lib, pkg) { }", NULL, package_hooks_linter()) + linter <- package_hooks_linter() + + expect_lint(".onAttach <- function(lib, pkg) { }", NULL, linter) + expect_lint(".onLoad <- function(lib, pkg) { }", NULL, linter) # args only need to start with those characters - expect_lint(".onAttach <- function(libname, pkgpath) { }", NULL, package_hooks_linter()) - expect_lint(".onLoad <- function(libXXXX, pkgYYYY) { }", NULL, package_hooks_linter()) + expect_lint(".onAttach <- function(libname, pkgpath) { }", NULL, linter) + expect_lint(".onLoad <- function(libXXXX, pkgYYYY) { }", NULL, linter) }) test_that("package_hooks_linter blocks invalid .onLoad() / .onAttach() arguments", { + linter <- package_hooks_linter() + onload_msg <- rex::rex(".onLoad() should take two arguments") + expect_lint( ".onAttach <- function(xxx, pkg) { }", rex::rex(".onAttach() should take two arguments"), - package_hooks_linter() - ) - expect_lint( - ".onLoad <- function(lib, yyy) { }", - rex::rex(".onLoad() should take two arguments"), - package_hooks_linter() + linter ) + expect_lint(".onLoad <- function(lib, yyy) { }", onload_msg, linter) # only one lint if both are wrong - expect_lint( - ".onLoad <- function(xxx, yyy) { }", - rex::rex(".onLoad() should take two arguments"), - package_hooks_linter() - ) + expect_lint(".onLoad <- function(xxx, yyy) { }", onload_msg, linter) # exactly two arguments required. # NB: QC.R allows ... arguments to be passed, but disallow this flexibility in the linter. - expect_lint( - ".onLoad <- function() { }", - rex::rex(".onLoad() should take two arguments"), - package_hooks_linter() - ) - expect_lint( - ".onLoad <- function(lib) { }", - rex::rex(".onLoad() should take two arguments"), - package_hooks_linter() - ) - expect_lint( - ".onLoad <- function(lib, pkg, third) { }", - rex::rex(".onLoad() should take two arguments"), - package_hooks_linter() - ) - expect_lint( - ".onLoad <- function(lib, ...) { }", - rex::rex(".onLoad() should take two arguments"), - package_hooks_linter() - ) + expect_lint(".onLoad <- function() { }", onload_msg, linter) + expect_lint(".onLoad <- function(lib) { }", onload_msg, linter) + expect_lint(".onLoad <- function(lib, pkg, third) { }", onload_msg, linter) + expect_lint(".onLoad <- function(lib, ...) { }", onload_msg, linter) }) test_that("package_hooks_linter skips valid namespace loading", { - expect_lint(".onAttach <- function(lib, pkg) { requireNamespace('foo') }", NULL, package_hooks_linter()) - expect_lint(".onLoad <- function(lib, pkg) { requireNamespace('foo') }", NULL, package_hooks_linter()) + linter <- package_hooks_linter() + + expect_lint(".onAttach <- function(lib, pkg) { requireNamespace('foo') }", NULL, linter) + expect_lint(".onLoad <- function(lib, pkg) { requireNamespace('foo') }", NULL, linter) }) test_that("package_hooks_linter blocks attaching namespaces", { + linter <- package_hooks_linter() + expect_lint( ".onAttach <- function(lib, pkg) { require(foo) }", rex::rex("Don't alter the search() path in .onAttach() by calling require()."), - package_hooks_linter() + linter ) expect_lint( ".onLoad <- function(lib, pkg) { library(foo) }", rex::rex("Don't alter the search() path in .onLoad() by calling library()."), - package_hooks_linter() + linter ) expect_lint( ".onLoad <- function(lib, pkg) { installed.packages() }", rex::rex("Don't slow down package load by running installed.packages() in .onLoad()."), - package_hooks_linter() + linter ) # find at further nesting too expect_lint( ".onAttach <- function(lib, pkg) { a(b(c(require(foo)))) }", rex::rex("Don't alter the search() path in .onAttach() by calling require()."), - package_hooks_linter() + linter ) expect_lint( ".onLoad <- function(lib, pkg) { d(e(f(library(foo)))) }", rex::rex("Don't alter the search() path in .onLoad() by calling library()."), - package_hooks_linter() + linter ) expect_lint( ".onLoad <- function(lib, pkg) { g(h(i(installed.packages()))) }", rex::rex("Don't slow down package load by running installed.packages() in .onLoad()."), - package_hooks_linter() + linter ) # also find when used as names expect_lint( ".onAttach <- function(lib, pkg) { sapply(c('a', 'b', 'c'), require, character.only = TRUE) }", rex::rex("Don't alter the search() path in .onAttach() by calling require()."), - package_hooks_linter() + linter ) expect_lint( ".onAttach <- function(lib, pkg) { lapply(c('a', 'b', 'c'), library, character.only = TRUE) }", rex::rex("Don't alter the search() path in .onAttach() by calling library()"), - package_hooks_linter() + linter ) }) test_that("package_hooks_linter skips valid .onDetach() and .Last.lib()", { - expect_lint(".onDetach <- function(lib) { }", NULL, package_hooks_linter()) - expect_lint(".onDetach <- function(libname) { }", NULL, package_hooks_linter()) + linter <- package_hooks_linter() + + expect_lint(".onDetach <- function(lib) { }", NULL, linter) + expect_lint(".onDetach <- function(libname) { }", NULL, linter) - expect_lint(".Last.lib <- function(lib) { }", NULL, package_hooks_linter()) - expect_lint(".Last.lib <- function(libname) { }", NULL, package_hooks_linter()) + expect_lint(".Last.lib <- function(lib) { }", NULL, linter) + expect_lint(".Last.lib <- function(libname) { }", NULL, linter) }) test_that("package_hooks_linter catches usage of library.dynam.unload()", { + linter <- package_hooks_linter() + expect_lint( ".onDetach <- function(lib) { library.dynam.unload() }", rex::rex("Use library.dynam.unload() calls in .onUnload(), not .onDetach()."), - package_hooks_linter() + linter ) expect_lint( ".Last.lib <- function(lib) { library.dynam.unload() }", rex::rex("Use library.dynam.unload() calls in .onUnload(), not .Last.lib()."), - package_hooks_linter() + linter ) # expected usage is in .onUnload expect_lint( ".onUnload <- function(lib) { library.dynam.unload() }", NULL, - package_hooks_linter() + linter ) }) test_that("package_hooks_linter detects bad argument names in .onDetach()/.Last.lib()", { + linter <- package_hooks_linter() + lint_msg_part <- " should take one argument starting with 'lib'" + expect_lint( ".onDetach <- function(xxx) { }", - rex::rex(".onDetach() should take one argument starting with 'lib'."), - package_hooks_linter() + rex::rex(".onDetach()", lint_msg_part), + linter ) expect_lint( ".Last.lib <- function(yyy) { }", - rex::rex(".Last.lib() should take one argument starting with 'lib'."), - package_hooks_linter() + rex::rex(".Last.lib()", lint_msg_part), + linter ) # exactly one argument required. # NB: QC.R allows ... arguments to be passed, but disallow this flexibility in the linter. expect_lint( ".onDetach <- function() { }", - rex::rex(".onDetach() should take one argument starting with 'lib'."), - package_hooks_linter() + rex::rex(".onDetach()", lint_msg_part), + linter ) expect_lint( ".Last.lib <- function(lib, pkg) { }", - rex::rex(".Last.lib() should take one argument starting with 'lib'."), - package_hooks_linter() + rex::rex(".Last.lib()", lint_msg_part), + linter ) expect_lint( ".onDetach <- function(...) { }", - rex::rex(".onDetach() should take one argument starting with 'lib'."), - package_hooks_linter() + rex::rex(".onDetach()", lint_msg_part), + linter ) }) @@ -277,3 +266,17 @@ test_that("function shorthand is handled", { linter ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + .onLoad <- function(xxx, yyy) { } + .onAttach <- function(aaa, bbb) { } + }"), + list( + list(".onLoad", line_number = 2L), + list(".onAttach", line_number = 3L) + ), + package_hooks_linter() + ) +}) diff --git a/tests/testthat/test-paren_body_linter.R b/tests/testthat/test-paren_body_linter.R index 64e2522b3..dac02cae4 100644 --- a/tests/testthat/test-paren_body_linter.R +++ b/tests/testthat/test-paren_body_linter.R @@ -1,6 +1,6 @@ testthat::test_that("paren_body_linter returns correct lints", { linter <- paren_body_linter() - lint_msg <- "There should be a space between a right parenthesis and a body expression." + lint_msg <- rex::rex("Put a space between a right parenthesis and a body expression.") # No space after the closing parenthesis prompts a lint expect_lint("function()test", lint_msg, linter) @@ -49,29 +49,32 @@ testthat::test_that("paren_body_linter returns correct lints", { }) test_that("multi-line versions are caught", { + linter <- paren_body_linter() + lint_msg <- rex::rex("Put a space between a right parenthesis and a body expression.") + expect_lint( trim_some(" function(var )x "), - rex::rex("There should be a space between a right parenthesis and a body expression."), - paren_body_linter() + lint_msg, + linter ) expect_lint( trim_some(" if (cond )x "), - rex::rex("There should be a space between a right parenthesis and a body expression."), - paren_body_linter() + lint_msg, + linter ) expect_lint( trim_some(" while (cond )x "), - rex::rex("There should be a space between a right parenthesis and a body expression."), - paren_body_linter() + lint_msg, + linter ) skip_if_not_r_version("4.1.0") @@ -80,15 +83,15 @@ test_that("multi-line versions are caught", { \\(var )x "), - rex::rex("There should be a space between a right parenthesis and a body expression."), - paren_body_linter() + lint_msg, + linter ) }) test_that("function shorthand is handled", { skip_if_not_r_version("4.1.0") linter <- paren_body_linter() - lint_msg <- rex::rex("There should be a space between a right parenthesis and a body expression.") + lint_msg <- rex::rex("Put a space between a right parenthesis and a body expression.") expect_lint("\\()test", lint_msg, linter) }) diff --git a/tests/testthat/test-pipe-consistency-linter.R b/tests/testthat/test-pipe_consistency_linter.R similarity index 88% rename from tests/testthat/test-pipe-consistency-linter.R rename to tests/testthat/test-pipe_consistency_linter.R index 2406e9831..4a236b156 100644 --- a/tests/testthat/test-pipe-consistency-linter.R +++ b/tests/testthat/test-pipe_consistency_linter.R @@ -21,7 +21,7 @@ test_that("pipe_consistency skips allowed usage", { test_that("pipe_consistency lints inconsistent usage", { skip_if_not_r_version("4.1.0") linter <- pipe_consistency_linter() - expected_msg <- rex("Found 1 instances of %>% and 1 instances of |>. Stick to one pipe operator.") + expected_msg <- rex::rex("Stick to one pipe operator; found 1 instances of %>% and 1 instances of |>.") expect_lint( "1:3 |> mean() %>% as.character()", @@ -54,7 +54,7 @@ test_that("pipe_consistency lints inconsistent usage", { linter ) - expected_msg_multi <- rex("Found 1 instances of %>% and 2 instances of |>. Stick to one pipe operator.") + expected_msg_multi <- rex::rex("Stick to one pipe operator; found 1 instances of %>% and 2 instances of |>.") expect_lint( "1:3 |> sort() |> mean() %>% as.character()", list( @@ -71,7 +71,7 @@ test_that("pipe_consistency_linter works with |> argument", { skip_if_not_r_version("4.1.0") linter <- pipe_consistency_linter(pipe = "|>") - expected_message <- rex("Use the |> pipe operator instead of the %>% pipe operator.") + expected_message <- rex::rex("Use the |> pipe operator instead of the %>% pipe operator.") expect_lint( trim_some(" @@ -117,7 +117,7 @@ test_that("pipe_consistency_linter works with %>% argument", { skip_if_not_r_version("4.1.0") linter <- pipe_consistency_linter(pipe = "%>%") - expected_message <- rex("Use the %>% pipe operator instead of the |> pipe operator.") + expected_message <- rex::rex("Use the %>% pipe operator instead of the |> pipe operator.") expect_lint( "1:3 |> mean() |> as.character()", @@ -154,7 +154,7 @@ test_that("pipe_consistency_linter works with %>% argument", { test_that("pipe_consistency_linter works with other magrittr pipes", { skip_if_not_r_version("4.1.0") linter <- pipe_consistency_linter() - expected_message <- rex("Found 1 instances of %>% and 1 instances of |>. Stick to one pipe operator.") + expected_message <- rex::rex("Stick to one pipe operator; found 1 instances of %>% and 1 instances of |>.") expect_lint("1:3 %>% mean() %T% print()", NULL, linter) expect_lint( diff --git a/tests/testthat/test-pipe_continuation_linter.R b/tests/testthat/test-pipe_continuation_linter.R index 5f8fd4869..528f0c011 100644 --- a/tests/testthat/test-pipe_continuation_linter.R +++ b/tests/testthat/test-pipe_continuation_linter.R @@ -1,6 +1,6 @@ test_that("pipe-continuation correctly handles stand-alone expressions", { linter <- pipe_continuation_linter() - lint_msg <- rex::rex("`%>%` should always have a space before it and a new line after it,") + lint_msg <- rex::rex("Put a space before `%>%` and a new line after it,") # Expressions without pipes are ignored expect_lint("blah", NULL, linter) @@ -41,7 +41,7 @@ test_that("pipe-continuation correctly handles stand-alone expressions", { test_that("pipe-continuation linter correctly handles nesting", { linter <- pipe_continuation_linter() - lint_msg <- rex::rex("`%>%` should always have a space before it and a new line after it,") + lint_msg <- rex::rex("Put a space before `%>%` and a new line after it,") expect_lint( trim_some(" @@ -81,8 +81,8 @@ test_that("pipe-continuation linter handles native pipe", { skip_if_not_r_version("4.1.0") linter <- pipe_continuation_linter() - lint_msg_native <- rex::rex("`|>` should always have a space before it and a new line after it,") - lint_msg_magrittr <- rex::rex("`%>%` should always have a space before it and a new line after it,") + lint_msg_native <- rex::rex("Put a space before `|>` and a new line after it,") + lint_msg_magrittr <- rex::rex("Put a space before `%>%` and a new line after it,") expect_lint("foo |> bar() |> baz()", NULL, linter) expect_lint( @@ -201,7 +201,7 @@ local({ "Various pipes are linted correctly", expect_lint( sprintf("a %s b() %s\n c()", pipe1, pipe2), - rex::rex(sprintf("`%s` should always have a space before it", pipe2)), + rex::rex(sprintf("Put a space before `%s` and a new line after it", pipe2)), linter ), .cases = cases diff --git a/tests/testthat/test-pipe_return_linter.R b/tests/testthat/test-pipe_return_linter.R index 0c395d48b..1d7af5f6c 100644 --- a/tests/testthat/test-pipe_return_linter.R +++ b/tests/testthat/test-pipe_return_linter.R @@ -41,7 +41,27 @@ test_that("pipe_return_linter blocks simple disallowed usages", { ") expect_lint( lines, - rex::rex("Using return() as the final step of a magrittr pipeline"), + rex::rex("Avoid return() as the final step of a magrittr pipeline"), + pipe_return_linter() + ) +}) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Avoid return() as the final step of a magrittr pipeline") + + expect_lint( + trim_some("{ + function(x) { + x %>% return() + } + function(y) { + y %>% return() + } + }"), + list( + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 6L) + ), pipe_return_linter() ) }) diff --git a/tests/testthat/test-quotes_linter.R b/tests/testthat/test-quotes_linter.R index d5e3f9859..3558cbe27 100644 --- a/tests/testthat/test-quotes_linter.R +++ b/tests/testthat/test-quotes_linter.R @@ -76,3 +76,19 @@ test_that("single_quotes_linter is deprecated", { expect_lint('"blah"', NULL, old_linter) expect_lint("'blah'", "Only use double-quotes", old_linter) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Only use double-quotes.") + + expect_lint( + trim_some("{ + 'abc' + 'def' + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + quotes_linter() + ) +}) diff --git a/tests/testthat/test-redundant_equals_linter.R b/tests/testthat/test-redundant_equals_linter.R index 8459a0ae4..541237f83 100644 --- a/tests/testthat/test-redundant_equals_linter.R +++ b/tests/testthat/test-redundant_equals_linter.R @@ -7,10 +7,15 @@ test_that("redundant_equals_linter skips allowed usages", { test_that("multiple lints return correct custom messages", { expect_lint( - "list(x == TRUE, y != TRUE)", + trim_some(" + list( + x == TRUE, + y != TRUE + ) + "), list( - "Using == on a logical vector", - "Using != on a logical vector" + list("Using == on a logical vector", line_number = 2L), + list("Using != on a logical vector", line_number = 3L) ), redundant_equals_linter() ) diff --git a/tests/testthat/test-redundant_ifelse_linter.R b/tests/testthat/test-redundant_ifelse_linter.R index 999116add..bf7fbc0ae 100644 --- a/tests/testthat/test-redundant_ifelse_linter.R +++ b/tests/testthat/test-redundant_ifelse_linter.R @@ -144,3 +144,17 @@ test_that("ifelse(missing = ) gives correct lints", { expect_lint("if_else(x > 5, 'a', 0L, 1L)", NULL, linter) expect_lint("if_else(x > 5, 'a', 1, 0)", NULL, linter) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + ifelse(x > 0, TRUE, FALSE) + fifelse(y == 0, 1, 0) + }"), + list( + list("Just use the logical condition", line_number = 2L), + list(rex::rex("refer as.numeric(x)"), line_number = 3L) + ), + redundant_ifelse_linter() + ) +}) diff --git a/tests/testthat/test-regex_subset_linter.R b/tests/testthat/test-regex_subset_linter.R index 2bd163181..27303ee40 100644 --- a/tests/testthat/test-regex_subset_linter.R +++ b/tests/testthat/test-regex_subset_linter.R @@ -4,23 +4,12 @@ test_that("regex_subset_linter skips allowed usages", { }) test_that("regex_subset_linter blocks simple disallowed usages", { - expect_lint( - "x[grep(ptn, x)]", - rex::rex("Prefer grep(pattern, x, ..., value = TRUE)"), - regex_subset_linter() - ) - - expect_lint( - "names(y)[grepl(ptn, names(y), perl = TRUE)]", - rex::rex("Prefer grep(pattern, x, ..., value = TRUE)"), - regex_subset_linter() - ) + linter <- regex_subset_linter() + lint_msg <- rex::rex("Prefer grep(pattern, x, ..., value = TRUE)") - expect_lint( - "names(foo(y))[grepl(ptn, names(foo(y)), fixed = TRUE)]", - rex::rex("Prefer grep(pattern, x, ..., value = TRUE)"), - regex_subset_linter() - ) + expect_lint("x[grep(ptn, x)]", lint_msg, linter) + expect_lint("names(y)[grepl(ptn, names(y), perl = TRUE)]", lint_msg, linter) + expect_lint("names(foo(y))[grepl(ptn, names(foo(y)), fixed = TRUE)]", lint_msg, linter) }) test_that("regex_subset_linter skips grep/grepl subassignment", { @@ -42,15 +31,23 @@ test_that("regex_subset_linter skips allowed usages for stringr equivalents", { }) test_that("regex_subset_linter blocks disallowed usages for stringr equivalents", { - expect_lint( - "x[str_which(x, ptn)]", - rex::rex("Prefer stringr::str_subset(x, pattern) over"), - regex_subset_linter() - ) + linter <- regex_subset_linter() + lint_msg <- rex::rex("Prefer stringr::str_subset(x, pattern) over") + + expect_lint("x[str_which(x, ptn)]", lint_msg, linter) + expect_lint("names(y)[str_detect(names(y), ptn, negate = TRUE)]", lint_msg, linter) +}) +test_that("lints vectorize", { expect_lint( - "names(y)[str_detect(names(y), ptn, negate = TRUE)]", - rex::rex("Prefer stringr::str_subset(x, pattern) over"), + trim_some("{ + x[grep(ptn, x)] + y[str_detect(y, ptn)] + }"), + list( + list(rex::rex("Prefer grep"), line_number = 2L), + list(rex::rex("Prefer stringr::str_subset"), line_number = 3L) + ), regex_subset_linter() ) }) diff --git a/tests/testthat/test-return_linter.R b/tests/testthat/test-return_linter.R index d412820bf..b05b3abd3 100644 --- a/tests/testthat/test-return_linter.R +++ b/tests/testthat/test-return_linter.R @@ -9,7 +9,8 @@ test_that("Lint return on end of function", { "), list( line_number = 4L, - message = rex::rex("All functions must have an explicit return().") + message = rex::rex("All functions must have an explicit return()."), + type = "warning" ), return_linter(return_style = "explicit") ) @@ -22,7 +23,8 @@ test_that("Lint return on end of function", { "), list( line_number = 2L, - message = rex::rex("Use implicit return behavior; explicit return() is not needed.") + message = rex::rex("Use implicit return behavior; explicit return() is not needed."), + type = "style" ), return_linter() ) @@ -135,7 +137,7 @@ test_that("Lint control statements (without return) on end of function", { } } "), - list(lint_msg, line_number = 4L), + list(lint_msg, line_number = 5L), linter ) }) @@ -164,56 +166,6 @@ test_that("Do not lint stop on end of function", { ) }) -test_that("Do not lint stop on end of function", { - linter <- return_linter(return_style = "explicit") - lint_msg <- rex::rex("All functions must have an explicit return().") - - expect_lint( - trim_some(" - function(x) { - switch(x, a = 1, 'b' = 2, '3' = 3, 4) - } - "), - list(lint_msg, line_number = 2L), - linter - ) - - expect_lint( - trim_some(" - function(x) { - switch(x, a = return(1), 'b' = stop(2), '3' = return(3), 4) - } - "), - list(lint_msg, line_number = 2L), - linter - ) - - expect_lint( - trim_some(" - function() { - switch( - x, - a = return(1), - 'b' = stop(2), - '3' = return(3) - ) - } - "), - list(lint_msg, line_number = 2L), - linter - ) - - expect_lint( - trim_some(" - function(x) { - switch(x, a = return(1), 'b' = stop(2), '3' = return(3), stop('End')) - } - "), - list(lint_msg, line_number = 2L), - linter - ) -}) - test_that("return_linter works in simple function", { expect_lint( trim_some(" @@ -331,8 +283,8 @@ test_that("return_linter finds multiple missing returns in branches", { } "), list( - list(lint_msg, line_number = 2L), - list(lint_msg, line_number = 4L) + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 5L) ), return_linter(return_style = "explicit") ) @@ -696,6 +648,72 @@ test_that("except= argument works", { ) }) +test_that("except_regex= argument works", { + linter <- return_linter(return_style = "explicit", except_regex = "^Test") + + expect_lint( + trim_some(" + TestSummary <- function() { + context <- foo(72643424) + expected <- data.frame(a = 2) + checkEquals(expected, bar(context)) + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + TestMyPackage <- function() { + checkMyCustomComparator(x, y) + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + TestOuter <- function() { + actual <- lapply( + input, + function(x) { + no_return() + } + ) + TestInner <- function() { + no_return() + } + checkEquals(TestInner(), actual) + } + "), + list(rex::rex("All functions must have an explicit return()."), line_number = 5L), + linter + ) +}) + +test_that("except= and except_regex= combination works", { + expect_lint( + trim_some(" + foo <- function() { + no_return() + } + bar <- function() { + no_return() + } + abaz <- function() { + no_return() + } + bbaz <- function() { + no_return() + } + "), + NULL, + return_linter(return_style = "explicit", except = c("foo", "bar"), except_regex = "baz$") + ) +}) + test_that("return_linter skips brace-wrapped inline functions", { expect_lint("function(x) { sum(x) }", NULL, return_linter(return_style = "explicit")) }) @@ -882,3 +900,927 @@ test_that("return_linter lints `message`, `warning` and `stopifnot`", { linter ) }) + +test_that("return_linter handles arbitrarily nested terminal statements", { + implicit_linter <- return_linter() + implicit_msg <- rex::rex("Use implicit return behavior; explicit return() is not needed.") + explicit_linter <- return_linter(return_style = "explicit") + explicit_msg <- rex::rex("All functions must have an explicit return().") + + expect_lint( + trim_some(" + foo <- function(x) { + if (x < 0) { + if (x == -1) { + return(TRUE) + } + if (x > -10) { + NA + } else { + FALSE + } + } else if (x == 0) { + TRUE + } else { + y <- x**2 + if (y > 10) { + z <- sin(y) + if (z > 0) { + FALSE + } else { + NA + } + } else { + TRUE + } + } + } + "), + NULL, + implicit_linter + ) + + expect_lint( + trim_some(" + foo <- function(x) { + if (x < 0) { + if (x == -1) { + return(TRUE) + } + if (x > -10) { + return(NA) + } else { + return(FALSE) + } + } else if (x == 0) { + return(TRUE) + } else { + y <- x**2 + if (y > 10) { + z <- sin(y) + if (z > 0) { + return(FALSE) + } else { + return(NA) + } + } else { + return(TRUE) + } + } + } + "), + NULL, + explicit_linter + ) + + mixed_lines <- trim_some(" + foo <- function(x) { + if (x < 0) { + if (x == -1) { + return(TRUE) + } + if (x > -10) { + return(NA) + } else { + FALSE + } + } else if (x == 0) { + return(TRUE) + } else { + y <- x**2 + if (y > 10) { + z <- sin(y) + if (z > 0) { + FALSE + } else { + return(NA) + } + } else { + TRUE + } + } + } + ") + + expect_lint( + mixed_lines, + list( + list(implicit_msg, line_number = 7L), + list(implicit_msg, line_number = 12L), + list(implicit_msg, line_number = 20L) + ), + implicit_linter + ) + + expect_lint( + mixed_lines, + list( + list(explicit_msg, line_number = 9L), + list(explicit_msg, line_number = 18L), + list(explicit_msg, line_number = 23L) + ), + explicit_linter + ) +}) + +test_that("explicit returns in control flow are linted correctly", { + linter <- return_linter() + lint_msg <- rex::rex("Use implicit return behavior") + + expect_lint( + trim_some(" + foo <- function(bar) { + if (TRUE) { + return(bar) + } else { + return(NULL) + } + } + "), + list(lint_msg, lint_msg), + linter + ) + + expect_lint( + trim_some(" + foo <- function() { + if (TRUE) { + if (TRUE) { + return(1) + } + 2 + } else { + 3 + } + } + "), + NULL, + linter + ) +}) + +# inspired by grid:::draw.all +# https://github.com/r-devel/r-svn/blob/eeff859e427b2399f1474427a531365d2672f52f/src/library/grid/R/grob.R#L1940 +test_that("logic is robust to absence of '{'", { + linter <- return_linter() + + expect_lint( + trim_some(" + foo <- function() { + if (TRUE) # comment is a neighbor of 'if' + FALSE + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + foo <- function() { + if (TRUE) + FALSE + else # cannot rely on 'else' expr being e.g. 7th + NA + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + foo <- function() { + if (TRUE) { + FALSE + } else # cannot rely on 'else' expr being e.g. 7th + NA + } + "), + NULL, + linter + ) +}) + +test_that("logic is robust to terminal comments under '{'", { + implicit_linter <- return_linter() + implicit_msg <- rex::rex("Use implicit return behavior; explicit return() is not needed.") + explicit_linter <- return_linter(return_style = "explicit") + explicit_msg <- rex::rex("All functions must have an explicit return().") + + expect_lint( + trim_some(" + foo <- function() { + return(TRUE) + # comment + } + "), + implicit_msg, + implicit_linter + ) + + expect_lint( + trim_some(" + foo <- function() { + return(TRUE) + # comment + } + "), + NULL, + explicit_linter + ) + + expect_lint( + trim_some(" + foo <- function() { + TRUE + # comment + } + "), + explicit_msg, + explicit_linter + ) +}) + +test_that("terminal = assignment is not an error", { + # key is this is not an node + expect_lint( + trim_some(" + foo <- function() { + a = 1 + } + "), + NULL, + return_linter() + ) +}) + +test_that("empty terminal '{' expression is handled correctly", { + implicit_linter <- return_linter() + implicit_msg <- rex::rex("Use implicit return behavior; explicit return() is not needed.") + explicit_linter <- return_linter(return_style = "explicit") + explicit_msg <- rex::rex("All functions must have an explicit return().") + + empty_inline <- "foo <- function() { }" + expect_lint(empty_inline, NULL, implicit_linter) + expect_lint(empty_inline, NULL, explicit_linter) + + empty_multiline <- trim_some(" + foo <- function() { + } + ") + expect_lint(empty_multiline, NULL, implicit_linter) + expect_lint(empty_multiline, NULL, explicit_linter) + + empty_comment <- trim_some(" + foo <- function() { + # this line intentionally left blank + } + ") + expect_lint(empty_comment, NULL, implicit_linter) + expect_lint(empty_comment, NULL, explicit_linter) + + empty_if_implicit <- trim_some(" + foo <- function() { + if (TRUE) { + } else { + FALSE + } + } + ") + expect_lint(empty_if_implicit, NULL, implicit_linter) + expect_lint( + empty_if_implicit, + list( + list(explicit_msg, line_number = 2L), + list(explicit_msg, line_number = 4L) + ), + explicit_linter + ) + + empty_else_implicit <- trim_some(" + foo <- function() { + if (TRUE) { + FALSE + } else { + } + } + ") + expect_lint(empty_else_implicit, NULL, implicit_linter) + expect_lint( + empty_else_implicit, + list( + list(explicit_msg, line_number = 3L), + list(explicit_msg, line_number = 4L) + ), + explicit_linter + ) + + empty_if_explicit <- trim_some(" + foo <- function() { + if (TRUE) { + } else { + return(FALSE) + } + } + ") + expect_lint(empty_if_explicit, list(implicit_msg, line_number = 4L), implicit_linter) + expect_lint(empty_if_explicit, list(explicit_msg, line_number = 2L), explicit_linter) + + empty_else_explicit <- trim_some(" + foo <- function() { + if (TRUE) { + return(FALSE) + } else { + } + } + ") + expect_lint(empty_else_explicit, list(implicit_msg, line_number = 3L), implicit_linter) + expect_lint(empty_else_explicit, list(explicit_msg, line_number = 4L), explicit_linter) + + empty_if_else <- trim_some(" + foo <- function() { + if (TRUE) { + } else { + } + } + ") + expect_lint(empty_if_else, NULL, implicit_linter) + expect_lint( + empty_if_else, + list( + list(explicit_msg, line_number = 2L), + list(explicit_msg, line_number = 3L) + ), + explicit_linter + ) + + weird <- trim_some(" + foo <- function() { + if (TRUE) {{{{ + 0 + }}}} else { + { return(1) } + } + } + ") + expect_lint(weird, list(implicit_msg, line_number = 5L), implicit_linter) + expect_lint(weird, list(explicit_msg, line_number = 3L), explicit_linter) +}) + +test_that("non-if returns are skipped under allow_implicit_else = FALSE", { + expect_lint( + trim_some(" + foo <- function(bar) { + bar + } + "), + NULL, + return_linter(allow_implicit_else = FALSE) + ) +}) + +test_that("if/else don't throw a lint under allow_implicit_else = FALSE", { + expect_lint( + trim_some(" + foo <- function(bar) { + if (TRUE) { + bar + } else { + NULL + } + } + "), + NULL, + return_linter(allow_implicit_else = FALSE) + ) +}) + +test_that("implicit else outside a function doesn't lint under allow_implicit_else = FALSE", { + expect_lint("if(TRUE) TRUE", NULL, return_linter(allow_implicit_else = FALSE)) +}) + +test_that("allow_implicit_else = FALSE identifies a simple implicit else", { + expect_lint( + trim_some(" + foo <- function(bar) { + if (TRUE) { + bar + } + } + "), + rex::rex("All functions with terminal if statements must have a corresponding terminal else clause"), + return_linter(allow_implicit_else = FALSE) + ) +}) + +test_that("allow_implicit_else = FALSE finds implicit else with nested if+else", { + lint_msg <- rex::rex("All functions with terminal if statements must have a corresponding terminal else clause") + + expect_lint( + trim_some(" + foo <- function() { + if (TRUE) { + if (TRUE) { + FALSE + } else { + TRUE + } + } + } + "), + lint_msg, + return_linter(allow_implicit_else = FALSE) + ) + + expect_lint( + trim_some(" + foo <- function() { + if (TRUE) { + if (TRUE) { + return(FALSE) + } else { + return(TRUE) + } + } + } + "), + lint_msg, + return_linter(return_style = "explicit", allow_implicit_else = FALSE) + ) +}) + +test_that("allow_implicit_else = FALSE works on anonymous/inline functions", { + expect_lint( + "lapply(rnorm(10), function(x) if (TRUE) x + 1)", + rex::rex("All functions with terminal if statements must"), + return_linter(allow_implicit_else = FALSE) + ) +}) + +test_that("side-effect functions like .onLoad ignore the lack of explicit else under allow_implicit_else = FALSE", { + expect_lint( + trim_some(" + .onAttach <- function(libname, pkgname) { + if (TRUE) foo() + } + "), + NULL, + return_linter(allow_implicit_else = FALSE) + ) + + expect_lint( + trim_some(" + .onAttach <- function(libname, pkgname) { + if (TRUE) return(foo()) + } + "), + NULL, + return_linter(return_style = "explicit", allow_implicit_else = FALSE) + ) +}) + +test_that("implicit else lint has the correct metadata", { + linter <- return_linter(return_style = "explicit", allow_implicit_else = FALSE) + lint_msg <- "All functions with terminal if statements" + + expect_lint( + trim_some(" + foo <- function(x, y = 3) { + if (x) { + return(x) + } + } + "), + list(lint_msg, line_number = 2L), + linter + ) + + expect_lint( + trim_some("{ + foo <- function(x, y = 3) { + if (x) { + return(x) + } + } + + bar <- function(x, y = 3) { + if (x) { + return(x) + } + } + + baz <- function(x, y = 3) { + if (x) return(x) + } + }"), + list( + list(lint_msg, line_number = 3L), + list(lint_msg, line_number = 9L), + list(lint_msg, line_number = 15L) + ), + linter + ) +}) + +test_that("Correct lints thrown when lacking explicit return and explicit else", { + linter <- return_linter(return_style = "explicit", allow_implicit_else = FALSE) + explicit_return_msg <- rex::rex("All functions must have an explicit return().") + implicit_else_msg <- rex::rex("All functions with terminal if statements") + + expect_lint( + trim_some(" + foo <- function(x, y = 3) { + if (x) { + x + } + } + "), + list( + list(implicit_else_msg, line_number = 2L), + list(explicit_return_msg, line_number = 3L) + ), + linter + ) + + expect_lint( + trim_some(" + function(x, y) { + if (x) { + 1 + } else if (y) { + 2 + } + } + "), + list( + list(explicit_return_msg, line_number = 3L), + list(implicit_else_msg, line_number = 4L), + list(explicit_return_msg, line_number = 5L) + ), + linter + ) +}) + +test_that("Mixing exempted functions doesn't miss lints", { + # in the current implementation, a local copy of 'params' is + # edited in a loop; this test ensures that behavior continues to be correct + expect_lint( + trim_some("{ + foo <- function() { + 1 + } + + bar <- function() { + if (TRUE) { + return(2) + } + } + + baz <- function() { + if (TRUE) { + 3 + } + } + }"), + list( + list("Use implicit return behavior", line_number = 8L), + list("All functions with terminal if statements", line_number = 13L) + ), + return_linter(allow_implicit_else = FALSE, except = "bar") + ) +}) + +test_that("= assignments are handled correctly", { + implicit_linter <- return_linter(allow_implicit_else = FALSE) + implicit_msg <- rex::rex("All functions with terminal if statements") + explicit_linter <- return_linter(return_style = "explicit") + explicit_msg <- rex::rex("All functions must have an explicit return().") + + expect_lint( + trim_some(" + .onLoad = function() { + 1 + } + "), + NULL, + explicit_linter + ) + + expect_lint( + trim_some(" + .onLoad = function() { + if (TRUE) 1 + } + "), + NULL, + implicit_linter + ) + + expect_lint( + trim_some(" + foo = function() { + 1 + } + "), + explicit_msg, + explicit_linter + ) + + expect_lint( + trim_some(" + foo = function() { + if (TRUE) 1 + } + "), + implicit_msg, + implicit_linter + ) +}) + +test_that("terminal switch() is handled correctly", { + implicit_linter <- return_linter() + implicit_msg <- rex::rex("Use implicit return behavior; explicit return() is not needed.") + explicit_linter <- return_linter(return_style = "explicit") + explicit_msg <- rex::rex("All functions must have an explicit return().") + + no_return_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = 1, + b = 2 + ) + } + ") + expect_lint(no_return_lines, NULL, implicit_linter) + expect_lint(no_return_lines, list(explicit_msg, explicit_msg), explicit_linter) + + outer_return_lines <- trim_some(" + foo <- function(x) { + return(switch(x, + a = 1, + b = 2 + )) + } + ") + expect_lint(outer_return_lines, implicit_msg, implicit_linter) + expect_lint(outer_return_lines, NULL, explicit_linter) + + partial_return_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = return(1), + b = 2 + ) + } + ") + expect_lint(partial_return_lines, implicit_msg, implicit_linter) + expect_lint(partial_return_lines, explicit_msg, explicit_linter) + + all_return_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = return(1), + b = return(2) + ) + } + ") + expect_lint(all_return_lines, list(implicit_msg, implicit_msg), implicit_linter) + expect_lint(all_return_lines, NULL, explicit_linter) + + default_all_return_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = return(1), + return(2) + ) + } + ") + expect_lint(default_all_return_lines, list(implicit_msg, implicit_msg), implicit_linter) + expect_lint(default_all_return_lines, NULL, explicit_linter) + + default_no_return_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = 1, + 2 + ) + } + ") + expect_lint(default_no_return_lines, NULL, implicit_linter) + expect_lint(default_no_return_lines, list(explicit_msg, explicit_msg), explicit_linter) + + no_return_braced_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = { + 1 + 2 + 3 + 4 + }, + b = { + 5 + 6 + 7 + } + ) + } + ") + expect_lint(no_return_braced_lines, NULL, implicit_linter) + expect_lint( + no_return_braced_lines, + list( + list(explicit_msg, line_number = 7L), + list(explicit_msg, line_number = 12L) + ), + explicit_linter + ) + + all_return_braced_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = { + 1 + 2 + 3 + return(4) + }, + b = { + 5 + 6 + return(7) + } + ) + } + ") + expect_lint( + all_return_braced_lines, + list( + list(implicit_msg, line_number = 7L), + list(implicit_msg, line_number = 12L) + ), + implicit_linter + ) + expect_lint(all_return_braced_lines, NULL, explicit_linter) + + early_return_braced_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = { + 1 + if (TRUE) { + return(2) + } + 3 + 4 + }, + b = { + 5 + 6 + 7 + } + ) + } + ") + expect_lint(early_return_braced_lines, NULL, implicit_linter) + expect_lint( + early_return_braced_lines, + list( + list(explicit_msg, line_number = 9L), + list(explicit_msg, line_number = 14L) + ), + explicit_linter + ) + + if_no_return_braced_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = { + 1 + if (TRUE) { + 2 + } else { + 3 + } + }, + b = { + 5 + 6 + 7 + } + ) + } + ") + expect_lint(if_no_return_braced_lines, NULL, implicit_linter) + expect_lint( + if_no_return_braced_lines, + list( + list(explicit_msg, line_number = 6L), + list(explicit_msg, line_number = 8L), + list(explicit_msg, line_number = 14L) + ), + explicit_linter + ) + + if_return_braced_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = { + 1 + if (TRUE) { + return(2) + } else { + return(3) + } + }, + b = { + 5 + 6 + return(7) + } + ) + } + ") + expect_lint( + if_return_braced_lines, + list( + list(implicit_msg, line_number = 6L), + list(implicit_msg, line_number = 8L), + list(implicit_msg, line_number = 14L) + ), + implicit_linter + ) + expect_lint(if_return_braced_lines, NULL, explicit_linter) + + ok_exit_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = .Call(a_routine, x), + b = .Call(b_routine, x), + stop('invalid') + ) + } + ") + expect_lint(ok_exit_lines, NULL, implicit_linter) + expect_lint(ok_exit_lines, NULL, explicit_linter) +}) + +test_that("switch() default statements interact with allow_implicit_else", { + implicit_linter <- return_linter(allow_implicit_else = FALSE) + explicit_linter <- return_linter(allow_implicit_else = FALSE, return_style = "explicit") + implicit_msg <- rex::rex("Use implicit return behavior; explicit return() is not needed.") + explicit_msg <- rex::rex("All functions must have an explicit return().") + implicit_switch_msg <- rex::rex("All functions with terminal switch statements") + implicit_else_msg <- rex::rex("All functions with terminal if statements") + + no_default_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = 1, + b = 2 + ) + } + ") + expect_lint(no_default_lines, list(implicit_switch_msg, line_number = 2L), implicit_linter) + expect_lint(no_default_lines, list(implicit_switch_msg, explicit_msg, explicit_msg), explicit_linter) + + ifelse_default_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = 1, + b = 2, + if (x != 'c') { + 3 + } else { + 4 + } + ) + } + ") + expect_lint(ifelse_default_lines, NULL, implicit_linter) + expect_lint(ifelse_default_lines, list(explicit_msg, explicit_msg, explicit_msg, explicit_msg), explicit_linter) + + if_no_else_default_lines <- trim_some(" + foo <- function(x) { + switch(x, + a = 1, + b = 2, + if (x != 'c') { + 3 + } + ) + } + ") + expect_lint(if_no_else_default_lines, list(implicit_else_msg, line_number = 5L), implicit_linter) + expect_lint( + if_no_else_default_lines, + list( + list(explicit_msg, line_number = 3L), + list(explicit_msg, line_number = 4L), + list(implicit_else_msg, line_number = 5L), + list(explicit_msg, line_number = 6L) + ), + explicit_linter + ) +}) diff --git a/tests/testthat/test-routine_registration_linter.R b/tests/testthat/test-routine_registration_linter.R index be03c9043..e0bdafefa 100644 --- a/tests/testthat/test-routine_registration_linter.R +++ b/tests/testthat/test-routine_registration_linter.R @@ -12,3 +12,19 @@ patrick::with_parameters_test_that( .test_name = c(".C", ".Call", ".External", ".Fortran"), caller = c(".C", ".Call", ".External", ".Fortran") ) + +test_that("lints vectorize", { + lint_msg <- "Register your native code routines with useDynLib" + + expect_lint( + trim_some("{ + .C('ROUTINE', PACKAGE = 'foo') + .External('POUTINE', PACKAGE = 'bar') + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + routine_registration_linter() + ) +}) diff --git a/tests/testthat/test-rstudio_markers.R b/tests/testthat/test-rstudio_markers.R index 203e87a41..8aad2cee8 100644 --- a/tests/testthat/test-rstudio_markers.R +++ b/tests/testthat/test-rstudio_markers.R @@ -1,8 +1,10 @@ test_that("it returns markers which match lints", { - skip_if_not_installed("mockery") - - mockery::stub(rstudio_source_markers, "rstudioapi::callFun", function(...) list(...)) - mockery::stub(rstudio_source_markers, "rstudioapi::executeCommand", function(...) NULL) + skip_if_not_installed("rstudioapi") + local_mocked_bindings( + callFun = function(...) list(...), + executeCommand = function(...) NULL, + .package = "rstudioapi" + ) lint1 <- list(Lint( filename = "test_file", @@ -53,10 +55,12 @@ test_that("it returns markers which match lints", { }) test_that("it prepends the package path if it exists", { - skip_if_not_installed("mockery") - - mockery::stub(rstudio_source_markers, "rstudioapi::callFun", function(...) list(...)) - mockery::stub(rstudio_source_markers, "rstudioapi::executeCommand", function(...) NULL) + skip_if_not_installed("rstudioapi") + local_mocked_bindings( + callFun = function(...) list(...), + executeCommand = function(...) NULL, + .package = "rstudioapi" + ) lint3 <- list(Lint( filename = "test_file", @@ -80,10 +84,12 @@ test_that("it prepends the package path if it exists", { }) test_that("it returns an empty list of markers if there are no lints", { - skip_if_not_installed("mockery") - - mockery::stub(rstudio_source_markers, "rstudioapi::callFun", function(...) list(...)) - mockery::stub(rstudio_source_markers, "rstudioapi::executeCommand", function(...) NULL) + skip_if_not_installed("rstudioapi") + local_mocked_bindings( + callFun = function(...) list(...), + executeCommand = function(...) NULL, + .package = "rstudioapi" + ) lint4 <- `class<-`(list(), "lints") marker4 <- rstudio_source_markers(lint4) @@ -92,15 +98,17 @@ test_that("it returns an empty list of markers if there are no lints", { }) test_that("rstudio_source_markers apply to print within rstudio", { - skip_if_not_installed("mockery") - withr::local_options(lintr.rstudio_source_markers = TRUE) tmp <- withr::local_tempfile(lines = "1:ncol(x)") empty <- withr::local_tempfile(lines = character(0L)) - mockery::stub(print.lints, "rstudioapi::hasFun", function(x, ...) TRUE) - mockery::stub(print.lints, "rstudio_source_markers", function(x) cat("matched\n")) + skip_if_not_installed("rstudioapi") + local_mocked_bindings( + hasFun = function(...) TRUE, + .package = "rstudioapi" + ) + local_mocked_bindings(rstudio_source_markers = function(x) cat("matched\n")) l <- lint(tmp, seq_linter()) expect_output(print(l), "matched", fixed = TRUE) diff --git a/tests/testthat/test-scalar_in_linter.R b/tests/testthat/test-scalar_in_linter.R index 215639251..2bfd66f83 100644 --- a/tests/testthat/test-scalar_in_linter.R +++ b/tests/testthat/test-scalar_in_linter.R @@ -31,7 +31,10 @@ test_that("multiple lints are generated correctly", { x %in% 1 y %chin% "a" }'), - list("%in%", "%chin%"), + list( + list("%in%", line_number = 2L), + list("%chin%", line_number = 3L) + ), linter ) }) diff --git a/tests/testthat/test-semicolon_linter.R b/tests/testthat/test-semicolon_linter.R index ea809df37..6cb5dd538 100644 --- a/tests/testthat/test-semicolon_linter.R +++ b/tests/testthat/test-semicolon_linter.R @@ -1,7 +1,7 @@ test_that("Lint all semicolons", { linter <- semicolon_linter() - trail_msg <- "Trailing semicolons are not needed." - comp_msg <- "Compound semicolons are discouraged. Replace them by a newline." + trail_msg <- rex::rex("Remove trailing semicolons.") + comp_msg <- rex::rex("Replace compound semicolons by a newline.") # No semicolon expect_lint("", NULL, linter) diff --git a/tests/testthat/test-seq_linter.R b/tests/testthat/test-seq_linter.R index f7a3446e9..04333f752 100644 --- a/tests/testthat/test-seq_linter.R +++ b/tests/testthat/test-seq_linter.R @@ -1,161 +1,177 @@ test_that("other : expressions are fine", { linter <- seq_linter() - expect_lint("function() { 1:10 }", NULL, linter) - expect_lint("function(x) { 2:length(x) }", NULL, linter) - expect_lint("function(x) { 1:(length(x) || 1) }", NULL, linter) + expect_lint("1:10", NULL, linter) + expect_lint("2:length(x)", NULL, linter) + expect_lint("1:(length(x) || 1)", NULL, linter) }) test_that("seq_len(...) or seq_along(...) expressions are fine", { linter <- seq_linter() - expect_lint("function(x) { seq_len(x) }", NULL, linter) - expect_lint("function(x) { seq_along(x) }", NULL, linter) + expect_lint("seq_len(x)", NULL, linter) + expect_lint("seq_along(x)", NULL, linter) - expect_lint("function(x) { seq(2, length(x)) }", NULL, linter) - expect_lint("function(x) { seq(length(x), 2) }", NULL, linter) + expect_lint("seq(2, length(x))", NULL, linter) + expect_lint("seq(length(x), 2)", NULL, linter) }) test_that("finds seq(...) expressions", { linter <- seq_linter() + lint_msg <- function(want, got) rex::rex("Use ", want, " instead of ", got) expect_lint( - "function(x) { seq(length(x)) }", - rex::rex("seq(length(...))", anything, "Use seq_along(...)"), + "seq(length(x))", + lint_msg("seq_along(...)", "seq(length(...))"), linter ) expect_lint( - "function(x) { seq(nrow(x)) }", - rex::rex("seq(nrow(...))", anything, "Use seq_len(nrow(...))"), + "seq(nrow(x))", + lint_msg("seq_len(nrow(...))", "seq(nrow(...))"), linter ) expect_lint( - "function(x) { rev(seq(length(x))) }", - rex::rex("seq(length(...))", anything, "Use seq_along(...)"), + "rev(seq(length(x)))", + lint_msg("seq_along(...)", "seq(length(...))"), linter ) expect_lint( - "function(x) { rev(seq(nrow(x))) }", - rex::rex("seq(nrow(...))", anything, "Use seq_len(nrow(...))"), + "rev(seq(nrow(x)))", + lint_msg("seq_len(nrow(...))", "seq(nrow(...))"), linter ) }) test_that("finds 1:length(...) expressions", { linter <- seq_linter() + lint_msg <- function(want, got) rex::rex("Use ", want, " instead of ", got) expect_lint( - "function(x) { 1:length(x) }", - rex::rex("length(...)", anything, "Use seq_along"), + "1:length(x)", + lint_msg("seq_along(...)", "1:length(...)"), linter ) expect_lint( - "function(x) { 1:nrow(x) }", - rex::rex("nrow(...)", anything, "Use seq_len"), + "1:nrow(x)", + lint_msg("seq_len(nrow(...))", "1:nrow(...)"), linter ) expect_lint( - "function(x) { 1:ncol(x) }", - rex::rex("ncol(...)", anything, "Use seq_len"), + "1:ncol(x)", + lint_msg("seq_len(ncol(...))", "1:ncol(...)"), linter ) expect_lint( - "function(x) { 1:NROW(x) }", - rex::rex("NROW(...)", anything, "Use seq_len"), + "1:NROW(x)", + lint_msg("seq_len(NROW(...))", "1:NROW(...)"), linter ) expect_lint( - "function(x) { 1:NCOL(x) }", - rex::rex("NCOL(...)", anything, "Use seq_len"), + "1:NCOL(x)", + lint_msg("seq_len(NCOL(...))", "1:NCOL(...)"), linter ) expect_lint( - "function(x) { 1:dim(x)[1L] }", - rex::rex("dim(...)", anything, "Use seq_len"), + "1:dim(x)[1L]", + lint_msg("seq_len(dim(...)[1L])", "1:dim(...)[1L]"), linter ) expect_lint( - "function(x) { 1L:dim(x)[[1]] }", - rex::rex("dim(...)", anything, "Use seq_len"), + "1L:dim(x)[[1]]", + rex::rex("Use seq_len", anything, "dim(...)"), linter ) expect_lint( - "function(x) { mutate(x, .id = 1:n()) }", - rex::rex("n() is", anything, "Use seq_len"), + "mutate(x, .id = 1:n())", + lint_msg("seq_len(n())", "1:n(),"), linter ) expect_lint( - "function(x) { x[, .id := 1:.N] }", - rex::rex(".N is", anything, "Use seq_len"), + "x[, .id := 1:.N]", + lint_msg("seq_len(.N)", "1:.N,"), linter ) }) test_that("1L is also bad", { expect_lint( - "function(x) { 1L:length(x) }", - rex::rex("1L:length(...)", anything, "Use seq_along"), + "1L:length(x)", + rex::rex("seq_along", anything, "1L:length(...)"), seq_linter() ) }) test_that("reverse seq is ok", { linter <- seq_linter() - expect_lint("function(x) { rev(seq_along(x)) }", NULL, linter) - expect_lint("function(x) { rev(seq_len(nrow(x))) }", NULL, linter) + expect_lint("rev(seq_along(x))", NULL, linter) + expect_lint("rev(seq_len(nrow(x)))", NULL, linter) expect_lint( - "function(x) { length(x):1 }", - rex::rex("length(...):1", anything, "Use rev(seq_along(...))"), - seq_linter() + "length(x):1", + rex::rex("rev(seq_along(...))", anything, "length(...):1"), + linter ) }) test_that("Message vectorization works for multiple lints", { + linter <- seq_linter() + expect_lint( - "c(1:length(x), 1:nrow(y))", + trim_some("{ + 1:length(x) + 1:nrow(y) + }"), list( - rex::rex("1:length(...)", anything, "seq_along(...)"), - rex::rex("1:nrow(...)", anything, "seq_len(nrow(...))") + list(rex::rex("seq_along(...)", anything, "1:length(...)"), line_number = 2L), + list(rex::rex("seq_len(nrow(...))", anything, "1:nrow(...)"), line_number = 3L) ), - seq_linter() + linter ) expect_lint( - "c(seq(length(x)), 1:nrow(y))", + trim_some("{ + seq(length(x)) + 1:nrow(y) + }"), list( - rex::rex("seq(length(...))", anything, "seq_along(...)"), - rex::rex("1:nrow(...)", anything, "seq_len(nrow(...))") + list(rex::rex("seq_along(...)", anything, "seq(length(...))"), line_number = 2L), + list(rex::rex("seq_len(nrow(...))", anything, "1:nrow(...)"), line_number = 3L) ), - seq_linter() + linter ) expect_lint( - "c(seq(length(x)), seq(nrow(y)))", + trim_some("{ + seq(length(x)) + seq(nrow(y)) + }"), list( - rex::rex("seq(length(...))", anything, "seq_along(...)"), - rex::rex("seq(nrow(...))", anything, "seq_len(nrow(...))") + list(rex::rex("seq_along(...)", anything, "seq(length(...))"), line_number = 2L), + list(rex::rex("seq_len(nrow(...))", anything, "seq(nrow(...))"), line_number = 3L) ), - seq_linter() + linter ) expect_lint( - "c(1:NROW(x), seq(NCOL(y)))", + trim_some("{ + 1:NROW(x) + seq(NCOL(y)) + }"), list( - rex::rex("1:NROW(...)", anything, "seq_len(NROW(...)"), - rex::rex("seq(NCOL(...))", anything, "seq_len(NCOL(...))") + list(rex::rex("seq_len(NROW(...))", anything, "1:NROW(...)"), line_number = 2L), + list(rex::rex("seq_len(NCOL(...))", anything, "seq(NCOL(...))"), line_number = 3L) ), - seq_linter() + linter ) }) diff --git a/tests/testthat/test-settings.R b/tests/testthat/test-settings.R index f9350c6a0..ffd166b25 100644 --- a/tests/testthat/test-settings.R +++ b/tests/testthat/test-settings.R @@ -282,3 +282,19 @@ test_that("perl-only regular expressions are accepted in config", { writeLines("a <- 1", "aaa.R") expect_silent(lint("aaa.R")) }) + +test_that("settings can be put in a sub-directory", { + withr::local_dir(withr::local_tempdir()) + + dir.create(".settings") + .lintr <- ".settings/.lintr.R" + writeLines("linters <- list(line_length_linter(10))", .lintr) + + dir.create("R") + writeLines("abcdefghijklmnopqrstuvwxyz=1", "R/a.R") + + writeLines(c("Package: foo", "Version: 0.1"), "DESCRIPTION") + + withr::local_options(lintr.linter_file = .lintr) + expect_length(lint_package(), 1L) +}) diff --git a/tests/testthat/test-sort_linter.R b/tests/testthat/test-sort_linter.R index ca0145dd9..15d8ab209 100644 --- a/tests/testthat/test-sort_linter.R +++ b/tests/testthat/test-sort_linter.R @@ -118,3 +118,17 @@ test_that("sort_linter blocks simple disallowed usages", { # expression matching expect_lint("sort(foo(x)) == foo(x)", sorted_msg, linter) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + x == sort(x) + y[order(y)] + }"), + list( + list(rex::rex("is.unsorted(x)"), line_number = 2L), + list(rex::rex("sort(y"), line_number = 3L) + ), + sort_linter() + ) +}) diff --git a/tests/testthat/test-spaces_left_parentheses_linter.R b/tests/testthat/test-spaces_left_parentheses_linter.R index b50e48efa..ce854828c 100644 --- a/tests/testthat/test-spaces_left_parentheses_linter.R +++ b/tests/testthat/test-spaces_left_parentheses_linter.R @@ -95,3 +95,19 @@ test_that("doesn't produce a warning", { expect_no_warning(lint(text = complex_lines, linters = spaces_left_parentheses_linter())) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Place a space before left parenthesis, except in a function call.") + + expect_lint( + trim_some("{ + y1<-(abs(yn)>90)*1 + for(i in j) { } + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + spaces_left_parentheses_linter() + ) +}) diff --git a/tests/testthat/test-sprintf_linter.R b/tests/testthat/test-sprintf_linter.R index 3e9b9c4cd..e0626a974 100644 --- a/tests/testthat/test-sprintf_linter.R +++ b/tests/testthat/test-sprintf_linter.R @@ -131,3 +131,19 @@ local({ .test_name = names(pipes) ) }) + +test_that("lints vectorize", { + skip_if_not_r_version("4.1.0") + + expect_lint( + trim_some("{ + sprintf('%s', a, b) + sprintf('%s%s', a) + }"), + list( + list("one argument not used by format", line_number = 2L), + list("too few arguments", line_number = 3L) + ), + sprintf_linter() + ) +}) diff --git a/tests/testthat/test-string_boundary_linter.R b/tests/testthat/test-string_boundary_linter.R index 875304048..a76630675 100644 --- a/tests/testthat/test-string_boundary_linter.R +++ b/tests/testthat/test-string_boundary_linter.R @@ -71,78 +71,112 @@ test_that("string_boundary_linter blocks simple disallowed grepl() usages", { }) test_that("string_boundary_linter blocks simple disallowed str_detect() usages", { + linter <- string_boundary_linter() + expect_lint( "str_detect(x, '^a')", rex::rex("Use startsWith() to detect a fixed initial substring."), - string_boundary_linter() + linter ) expect_lint( "str_detect(x, 'a$')", rex::rex("Use endsWith() to detect a fixed terminal substring."), - string_boundary_linter() + linter ) }) test_that("string_boundary_linter blocks disallowed substr()/substring() usage", { - expect_lint( - "substr(x, 1L, 2L) == 'ab'", - rex::rex("Use startsWith() to detect an initial substring."), - string_boundary_linter() - ) + linter <- string_boundary_linter() + starts_message <- rex::rex("Use startsWith() to detect an initial substring.") + ends_message <- rex::rex("Use endsWith() to detect a terminal substring.") + + expect_lint("substr(x, 1L, 2L) == 'ab'", starts_message, linter) # end doesn't matter, just anchoring to 1L - expect_lint( - "substr(x, 1L, end) == 'ab'", - rex::rex("Use startsWith() to detect an initial substring."), - string_boundary_linter() - ) - expect_lint( - "substring(x, nchar(x) - 4L, nchar(x)) == 'abcde'", - rex::rex("Use endsWith() to detect a terminal substring."), - string_boundary_linter() - ) + expect_lint("substr(x, 1L, end) == 'ab'", starts_message, linter) + expect_lint("substring(x, nchar(x) - 4L, nchar(x)) == 'abcde'", ends_message, linter) # start doesn't matter, just anchoring to nchar(x) - expect_lint( - "substring(x, start, nchar(x)) == 'abcde'", - rex::rex("Use endsWith() to detect a terminal substring."), - string_boundary_linter() - ) + expect_lint("substring(x, start, nchar(x)) == 'abcde'", ends_message, linter) # more complicated expressions - expect_lint( - "substring(colnames(x), start, nchar(colnames(x))) == 'abc'", - rex::rex("Use endsWith() to detect a terminal substring."), - string_boundary_linter() - ) + expect_lint("substring(colnames(x), start, nchar(colnames(x))) == 'abc'", ends_message, linter) }) test_that("plain ^ or $ are skipped", { - expect_lint('grepl("^", x)', NULL, string_boundary_linter()) - expect_lint('grepl("$", x)', NULL, string_boundary_linter()) + linter <- string_boundary_linter() + + expect_lint('grepl("^", x)', NULL, linter) + expect_lint('grepl("$", x)', NULL, linter) }) test_that("substr inverted tests are caught as well", { + linter <- string_boundary_linter() + expect_lint( "substr(x, 1L, 2L) != 'ab'", rex::rex("Use startsWith() to detect an initial substring."), - string_boundary_linter() + linter ) expect_lint( "substring(x, nchar(x) - 4L, nchar(x)) != 'abcde'", rex::rex("Use endsWith() to detect a terminal substring."), - string_boundary_linter() + linter ) }) test_that("R>=4 raw strings are detected", { + linter <- string_boundary_linter() + skip_if_not_r_version("4.0.0") - expect_lint('grepl(R"(^.{3})", x)', NULL, string_boundary_linter()) + expect_lint('grepl(R"(^.{3})", x)', NULL, linter) expect_lint( 'grepl(R"(^abc)", x)', rex::rex("Use !is.na(x) & startsWith(x, string) to detect a fixed initial substring,"), - string_boundary_linter() + linter ) }) test_that("grepl() can optionally be ignored", { - expect_lint("grepl('^abc', x)", NULL, string_boundary_linter(allow_grepl = TRUE)) - expect_lint("grepl('xyz$', x)", NULL, string_boundary_linter(allow_grepl = TRUE)) + linter <- string_boundary_linter(allow_grepl = TRUE) + + expect_lint("grepl('^abc', x)", NULL, linter) + expect_lint("grepl('xyz$', x)", NULL, linter) +}) + +test_that("whole-string regex recommends ==, not {starts,ends}With()", { + linter <- string_boundary_linter() + lint_msg <- rex::rex("Use == to check for an exact string match.") + + expect_lint("grepl('^abc$', x)", lint_msg, linter) + expect_lint("grepl('^a\\\\.b$', x)", lint_msg, linter) + expect_lint("str_detect(x, '^abc$')", lint_msg, linter) + expect_lint("str_detect(x, '^a[.]b$')", lint_msg, linter) +}) + +test_that("vectorization + metadata work as intended", { + expect_lint( + trim_some("{ + substring(a, 1, 3) == 'abc' + substring(b, nchar(b) - 3, nchar(b)) == 'defg' + substr(c, 1, 3) == 'hij' + substr(d, nchar(d) - 3, nchar(d)) == 'klmn' + grepl('^abc', e) + grepl('abc$', f) + grepl('^abc$', g) + str_detect(h, '^abc') + str_detect(i, 'abc$') + str_detect(j, '^abc$') + }"), + list( + list("startsWith", line_number = 2L), + list("endsWith", line_number = 3L), + list("startsWith", line_number = 4L), + list("endsWith", line_number = 5L), + list("startsWith", line_number = 6L), + list("endsWith", line_number = 7L), + list("==", line_number = 8L), + list("startsWith", line_number = 9L), + list("endsWith", line_number = 10L), + list("==", line_number = 11L) + ), + string_boundary_linter() + ) }) diff --git a/tests/testthat/test-strings_as_factors_linter.R b/tests/testthat/test-strings_as_factors_linter.R index 725f98776..a45624b80 100644 --- a/tests/testthat/test-strings_as_factors_linter.R +++ b/tests/testthat/test-strings_as_factors_linter.R @@ -21,7 +21,7 @@ test_that("strings_as_factors_linter skips allowed usages", { test_that("strings_as_factors_linter blocks simple disallowed usages", { linter <- strings_as_factors_linter() - lint_msg <- "This code relies on the default value of stringsAsFactors" + lint_msg <- "Supply an explicit value for stringsAsFactors for this code" expect_lint("data.frame('a')", lint_msg, linter) expect_lint("data.frame(c('a', 'b'))", lint_msg, linter) @@ -38,7 +38,7 @@ test_that("strings_as_factors_linter blocks simple disallowed usages", { test_that("strings_as_factors_linters catches rep(char) usages", { linter <- strings_as_factors_linter() - lint_msg <- "This code relies on the default value of stringsAsFactors" + lint_msg <- "Supply an explicit value for stringsAsFactors for this code" expect_lint("data.frame(rep('a', 10L))", lint_msg, linter) expect_lint("data.frame(rep(c('a', 'b'), 10L))", lint_msg, linter) @@ -52,7 +52,7 @@ test_that("strings_as_factors_linters catches rep(char) usages", { test_that("strings_as_factors_linter catches character(), as.character() usages", { linter <- strings_as_factors_linter() - lint_msg <- "This code relies on the default value of stringsAsFactors" + lint_msg <- "Supply an explicit value for stringsAsFactors for this code" expect_lint("data.frame(a = character())", lint_msg, linter) expect_lint("data.frame(a = character(1L))", lint_msg, linter) @@ -64,7 +64,7 @@ test_that("strings_as_factors_linter catches character(), as.character() usages" test_that("strings_as_factors_linter catches more functions with string output", { linter <- strings_as_factors_linter() - lint_msg <- "This code relies on the default value of stringsAsFactors" + lint_msg <- "Supply an explicit value for stringsAsFactors for this code" expect_lint("data.frame(a = paste(1, 2, 3))", lint_msg, linter) expect_lint("data.frame(a = sprintf('%d', 1:10))", lint_msg, linter) @@ -76,3 +76,19 @@ test_that("strings_as_factors_linter catches more functions with string output", # but not for row.names expect_lint("data.frame(a = 1:10, row.names = paste(1:10))", NULL, linter) }) + +test_that("lints vectorize", { + lint_msg <- "Supply an explicit value for stringsAsFactors for this code" + + expect_lint( + trim_some("{ + data.frame('a') + data.frame('b') + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + strings_as_factors_linter() + ) +}) diff --git a/tests/testthat/test-system_file_linter.R b/tests/testthat/test-system_file_linter.R index 4884bee00..f60c3aa8c 100644 --- a/tests/testthat/test-system_file_linter.R +++ b/tests/testthat/test-system_file_linter.R @@ -1,18 +1,30 @@ test_that("system_file_linter skips allowed usages", { - expect_lint("system.file('a', 'b', 'c')", NULL, system_file_linter()) - expect_lint("file.path('a', 'b', 'c')", NULL, system_file_linter()) + linter <- system_file_linter() + + expect_lint("system.file('a', 'b', 'c')", NULL, linter) + expect_lint("file.path('a', 'b', 'c')", NULL, linter) }) test_that("system_file_linter blocks simple disallowed usages", { - expect_lint( - "system.file(file.path('path', 'to', 'data'), package = 'foo')", - rex::rex("Use the `...` argument of system.file() to expand paths"), - system_file_linter() - ) + linter <- system_file_linter() + lint_msg <- rex::rex("Use the `...` argument of system.file() to expand paths") + + expect_lint("system.file(file.path('path', 'to', 'data'), package = 'foo')", lint_msg, linter) + expect_lint("file.path(system.file(package = 'foo'), 'path', 'to', 'data')", lint_msg, linter) +}) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Use the `...` argument of system.file() to expand paths") expect_lint( - "file.path(system.file(package = 'foo'), 'path', 'to', 'data')", - rex::rex("Use the `...` argument of system.file() to expand paths"), + trim_some("{ + file.path(system.file(package = 'foo'), 'bar') + system.file(file.path('bar', 'data'), package = 'foo') + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), system_file_linter() ) }) diff --git a/tests/testthat/test-todo_comment_linter.R b/tests/testthat/test-todo_comment_linter.R index 2d8abf520..103f9c8fc 100644 --- a/tests/testthat/test-todo_comment_linter.R +++ b/tests/testthat/test-todo_comment_linter.R @@ -1,8 +1,8 @@ test_that("returns the correct linting", { - linter <- todo_comment_linter(todo = c("todo", "fixme")) - lint_msg <- "TODO comments should be removed." + linter <- todo_comment_linter() + lint_msg <- rex::rex("Remove TODO comments.") - expect_lint("a <- \"you#need#to#fixme\"", NULL, linter) + expect_lint('a <- "you#need#to#fixme"', NULL, linter) expect_lint("# something todo", NULL, linter) expect_lint( "cat(x) ### fixme", @@ -15,11 +15,46 @@ test_that("returns the correct linting", { linter ) expect_lint( - "function() {\n# TODO\n function() {\n # fixme\n }\n}", + trim_some(" + function() { + # TODO + function() { + # fixme + } + } + "), list( - list(message = lint_msg, line_number = 2L, column_number = 1L), - list(message = lint_msg, line_number = 4L, column_number = 3L) + list(message = lint_msg, line_number = 2L, column_number = 3L), + list(message = lint_msg, line_number = 4L, column_number = 5L) ), linter ) }) + +test_that("except_regex= excludes valid TODO", { + linter <- todo_comment_linter(except_regex = "TODO\\(#[0-9]+\\):") + lint_msg <- rex::rex("Remove TODO comments.") + + expect_lint("foo() # TODO(#1234): Deprecate foo.", NULL, linter) + # Non-excepted lints + expect_lint( + trim_some(" + foo() # TODO() + bar() # TODO(#567): Deprecate bar. + "), + list(lint_msg, line_number = 1L), + linter + ) + # Only TODO() is excepted + mixed_lines <- trim_some(" + foo() # TODO(#1234): Deprecate foo. + bar() # fixme(#567): Deprecate bar. + ") + + expect_lint(mixed_lines, list(lint_msg, line_number = 2L), linter) + expect_lint( + mixed_lines, + NULL, + todo_comment_linter(except_regex = c("TODO\\(#[0-9]+\\):", "fixme\\(#[0-9]+\\):")) + ) +}) diff --git a/tests/testthat/test-trailing_blank_lines_linter.R b/tests/testthat/test-trailing_blank_lines_linter.R index 7ec9229ca..5b6f89511 100644 --- a/tests/testthat/test-trailing_blank_lines_linter.R +++ b/tests/testthat/test-trailing_blank_lines_linter.R @@ -12,7 +12,7 @@ test_that("trailing_blank_lines_linter doesn't block allowed usages", { test_that("trailing_blank_lines_linter detects disallowed usages", { linter <- trailing_blank_lines_linter() - lint_msg <- rex::rex("Trailing blank lines are superfluous.") + lint_msg <- rex::rex("Remove trailing blank lines.") expect_lint("blah <- 1\n", lint_msg, linter) expect_lint("blah <- 1\n ", lint_msg, linter) @@ -27,7 +27,7 @@ test_that("trailing_blank_lines_linter detects disallowed usages", { expect_lint( file = tmp2, checks = list( - message = rex::rex("Missing terminal newline."), + message = rex::rex("Add a terminal newline."), line_number = 1L, column_number = 10L ), @@ -37,6 +37,7 @@ test_that("trailing_blank_lines_linter detects disallowed usages", { test_that("trailing_blank_lines_linter detects missing terminal newlines in Rmd/qmd docs", { linter <- trailing_blank_lines_linter() + lint_msg <- rex::rex("Add a terminal newline") tmp3 <- withr::local_tempfile(fileext = ".Rmd") cat( @@ -56,12 +57,8 @@ test_that("trailing_blank_lines_linter detects missing terminal newlines in Rmd/ ) expect_lint( file = tmp3, - checks = list( - message = rex::rex("Missing terminal newline."), - line_number = 10L, - # We can't get 4 here because the line is NA-masked in get_source_expressions(), so no line length info exists. - column_number = 1L - ), + # We can't get 4 here because the line is NA-masked in get_source_expressions(), so no line length info exists. + checks = list(lint_msg, line_number = 10L, column_number = 1L), linters = linter ) @@ -79,12 +76,8 @@ test_that("trailing_blank_lines_linter detects missing terminal newlines in Rmd/ ) expect_lint( file = tmp4, - checks = list( - message = rex::rex("Missing terminal newline."), - line_number = 5L, - # We can't get 4 here because the line is NA-masked in get_source_expressions(), so no line length info exists. - column_number = 1L - ), + # We can't get 4 here because the line is NA-masked in get_source_expressions(), so no line length info exists. + checks = list(lint_msg, line_number = 5L, column_number = 1L), linters = linter ) @@ -107,18 +100,15 @@ test_that("trailing_blank_lines_linter detects missing terminal newlines in Rmd/ ) expect_lint( file = tmp5, - checks = list( - message = rex::rex("Missing terminal newline."), - line_number = 10L, - # We can't get 4 here because the line is NA-masked in get_source_expressions(), so no line length info exists. - column_number = 1L - ), + # We can't get 4 here because the line is NA-masked in get_source_expressions(), so no line length info exists. + checks = list(lint_msg, line_number = 10L, column_number = 1L), linters = linter ) }) test_that("blank lines in knitr chunks produce lints", { linter <- trailing_blank_lines_linter() + lint_msg <- rex::rex("Remove trailing blank lines.") tmp6 <- withr::local_tempfile( fileext = ".Rmd", @@ -137,7 +127,7 @@ test_that("blank lines in knitr chunks produce lints", { expect_lint( file = tmp6, - checks = list(message = rex::rex("Trailing blank lines are superfluous."), line_number = 7L, column_number = 1L), + checks = list(lint_msg, line_number = 7L, column_number = 1L), linters = linter ) @@ -161,9 +151,9 @@ test_that("blank lines in knitr chunks produce lints", { expect_lint( file = tmp7, checks = list( - list(message = rex::rex("Trailing blank lines are superfluous."), line_number = 7L, column_number = 1L), - list(message = rex::rex("Trailing blank lines are superfluous."), line_number = 8L, column_number = 1L), - list(message = rex::rex("Trailing blank lines are superfluous."), line_number = 9L, column_number = 1L) + list(lint_msg, line_number = 7L, column_number = 1L), + list(lint_msg, line_number = 8L, column_number = 1L), + list(lint_msg, line_number = 9L, column_number = 1L) ), linters = linter ) diff --git a/tests/testthat/test-trailing_whitespace_linter.R b/tests/testthat/test-trailing_whitespace_linter.R index e9159d87a..329f5a24f 100644 --- a/tests/testthat/test-trailing_whitespace_linter.R +++ b/tests/testthat/test-trailing_whitespace_linter.R @@ -1,39 +1,37 @@ test_that("returns the correct linting", { linter <- trailing_whitespace_linter() + lint_msg <- rex::rex("Remove trailing whitespace.") expect_lint("blah", NULL, linter) expect_lint( "blah <- 1 ", - list(message = rex::rex("Trailing whitespace is superfluous."), column_number = 10L), + list(message = lint_msg, column_number = 10L), linter ) - expect_lint( - "blah <- 1 \n'hi'", - rex::rex("Trailing whitespace is superfluous."), - linter - ) + expect_lint("blah <- 1 \n'hi'", lint_msg, linter) expect_lint( "blah <- 1\n'hi'\na <- 2 ", - list(message = rex::rex("Trailing whitespace is superfluous."), line_number = 3L), + list(message = lint_msg, line_number = 3L), linter ) }) test_that("also handles completely empty lines per allow_empty_lines argument", { linter <- trailing_whitespace_linter() + lint_msg <- rex::rex("Remove trailing whitespace.") expect_lint( "blah <- 1\n \n'hi'\na <- 2", - list(message = rex::rex("Trailing whitespace is superfluous."), line_number = 2L), + list(message = lint_msg, line_number = 2L), linter ) expect_lint( "blah <- 1 ", - list(message = rex::rex("Trailing whitespace is superfluous."), column_number = 10L), + list(message = lint_msg, column_number = 10L), trailing_whitespace_linter(allow_empty_lines = TRUE) ) @@ -46,7 +44,7 @@ test_that("also handles completely empty lines per allow_empty_lines argument", test_that("also handles trailing whitespace in string constants", { linter <- trailing_whitespace_linter() - lint_msg <- rex::rex("Trailing whitespace is superfluous.") + lint_msg <- rex::rex("Remove trailing whitespace.") expect_lint("blah <- ' \n \n'", NULL, linter) # Don't exclude past the end of string diff --git a/tests/testthat/test-undesirable_function_linter.R b/tests/testthat/test-undesirable_function_linter.R index 6597904ea..c12cbf21b 100644 --- a/tests/testthat/test-undesirable_function_linter.R +++ b/tests/testthat/test-undesirable_function_linter.R @@ -1,7 +1,7 @@ test_that("linter returns correct linting", { linter <- undesirable_function_linter(fun = c(return = NA, log10 = "use log()")) - msg_return <- "Function \"return\" is undesirable.$" - msg_log10 <- "Function \"log10\" is undesirable. As an alternative, use log\\(\\)." + msg_return <- rex::rex('Avoid undesirable function "return".', end) + msg_log10 <- rex::rex('Avoid undesirable function "log10". As an alternative, use log().') expect_lint("x <- options()", NULL, linter) expect_lint("cat(\"Try to return\")", NULL, linter) diff --git a/tests/testthat/test-undesirable_operator_linter.R b/tests/testthat/test-undesirable_operator_linter.R index 9e98d40b1..35aa6c20b 100644 --- a/tests/testthat/test-undesirable_operator_linter.R +++ b/tests/testthat/test-undesirable_operator_linter.R @@ -1,7 +1,7 @@ test_that("linter returns correct linting", { linter <- undesirable_operator_linter(op = c("$" = "As an alternative, use the `[[` accessor.", "<<-" = NA)) - msg_assign <- rex::escape("Operator `<<-` is undesirable.") - msg_dollar <- rex::escape("Operator `$` is undesirable. As an alternative, use the `[[` accessor.") + msg_assign <- rex::escape("Avoid undesirable operator `<<-`.") + msg_dollar <- rex::escape("Avoid undesirable operator `$`. As an alternative, use the `[[` accessor.") expect_lint("x <- foo:::getObj()", NULL, linter) expect_lint("cat(\"10$\")", NULL, linter) @@ -20,20 +20,20 @@ test_that("linter returns correct linting", { test_that("undesirable_operator_linter handles '=' consistently", { linter <- undesirable_operator_linter(op = c("=" = "As an alternative, use '<-'")) - expect_lint("a = 2L", rex::rex("Operator `=` is undesirable."), linter) + expect_lint("a = 2L", rex::rex("Avoid undesirable operator `=`."), linter) expect_lint("lm(data = mtcars)", NULL, linter) expect_lint("function(a = 1) { }", NULL, linter) }) test_that("undesirable_operator_linter handles infixes correctly", { linter <- undesirable_operator_linter(list("%oo%" = NA)) - expect_lint("a %oo% b", rex::rex("Operator `%oo%` is undesirable"), linter) + expect_lint("a %oo% b", rex::rex("Avoid undesirable operator `%oo%`."), linter) expect_lint("a %00% b", NULL, linter) # somewhat special case: %% is in infix_metadata expect_lint( "foo(x %% y, x %/% y)", - rex::rex("Operator `%%` is undesirable"), + rex::rex("Avoid undesirable operator `%%`."), undesirable_operator_linter(list("%%" = NA)) ) }) @@ -42,9 +42,9 @@ test_that("undesirable_operator_linter vectorizes messages", { expect_lint( "x <<- c(pkg:::foo, bar %oo% baz)", list( - rex::rex("`<<-` is undesirable. It assigns"), - rex::rex("`:::` is undesirable. It accesses"), - rex::rex("`%oo%` is undesirable.", end) + rex::rex("Avoid undesirable operator `<<-`. It assigns"), + rex::rex("Avoid undesirable operator `:::`. It accesses"), + rex::rex("Avoid undesirable operator `%oo%`.", end) ), undesirable_operator_linter(modify_defaults(default_undesirable_operators, "%oo%" = NA)) ) diff --git a/tests/testthat/test-unnecessary_concatenation_linter.R b/tests/testthat/test-unnecessary_concatenation_linter.R index ba1e10078..e7af5f46b 100644 --- a/tests/testthat/test-unnecessary_concatenation_linter.R +++ b/tests/testthat/test-unnecessary_concatenation_linter.R @@ -12,8 +12,8 @@ test_that("unnecessary_concatenation_linter skips allowed usages", { test_that("unnecessary_concatenation_linter blocks disallowed usages", { linter <- unnecessary_concatenation_linter() - msg_c <- rex::escape('Unneeded concatenation of a constant. Remove the "c" call.') - msg_e <- rex::escape('Unneeded concatenation without arguments. Replace the "c" call by NULL') + msg_c <- rex::rex("Remove unnecessary c() of a constant.") + msg_e <- rex::rex("Replace unnecessary c() by NULL or, whenever possible, vector()") expect_lint( "c()", @@ -48,20 +48,15 @@ test_that("unnecessary_concatenation_linter blocks disallowed usages", { local({ pipes <- pipes(exclude = "%$%") linter <- unnecessary_concatenation_linter() + const_msg <- rex::rex("Remove unnecessary c() of a constant.") + no_arg_msg <- rex::rex("Replace unnecessary c() by NULL or, whenever possible, vector()") + patrick::with_parameters_test_that( "Correctly handles concatenation within magrittr pipes", { expect_lint(sprintf('"a" %s c("b")', pipe), NULL, linter) - expect_lint( - sprintf('"a" %s c()', pipe), - "Unneeded concatenation of a constant", - linter - ) - expect_lint( - sprintf('"a" %s list("b", c())', pipe), - "Unneeded concatenation without arguments", - linter - ) + expect_lint(sprintf('"a" %s c()', pipe), const_msg, linter) + expect_lint(sprintf('"a" %s list("b", c())', pipe), no_arg_msg, linter) }, pipe = pipes, .test_name = names(pipes) @@ -69,37 +64,35 @@ local({ }) test_that("symbolic expressions are allowed, except by request", { - expect_lint("c(alpha / 2)", NULL, unnecessary_concatenation_linter()) - expect_lint("c(paste0('.', 1:2))", NULL, unnecessary_concatenation_linter()) - expect_lint("c(DF[cond > 1, col])", NULL, unnecessary_concatenation_linter()) + linter <- unnecessary_concatenation_linter() + linter_strict <- unnecessary_concatenation_linter(allow_single_expression = FALSE) + message <- rex::rex("Remove unnecessary c() of a constant expression.") + + expect_lint("c(alpha / 2)", NULL, linter) + expect_lint("c(paste0('.', 1:2))", NULL, linter) + expect_lint("c(DF[cond > 1, col])", NULL, linter) # allow_single_expression = FALSE turns both into lints - linter <- unnecessary_concatenation_linter(allow_single_expression = FALSE) - message <- "Unneeded concatenation of a simple expression" - expect_lint("c(alpha / 2)", message, linter) - expect_lint("c(paste0('.', 1:2))", message, linter) - expect_lint("c(DF[cond > 1, col])", message, linter) + expect_lint("c(alpha / 2)", message, linter_strict) + expect_lint("c(paste0('.', 1:2))", message, linter_strict) + expect_lint("c(DF[cond > 1, col])", message, linter_strict) }) test_that("sequences with : are linted whenever a constant is involved", { linter <- unnecessary_concatenation_linter() - expect_lint("c(1:10)", "Unneeded concatenation of a constant", linter) - expect_lint("c(1:sum(x))", "Unneeded concatenation of a constant", linter) + linter_strict <- unnecessary_concatenation_linter(allow_single_expression = FALSE) + const_msg <- rex::rex("Remove unnecessary c() of a constant.") + expr_msg <- rex::rex("Remove unnecessary c() of a constant expression.") + + expect_lint("c(1:10)", const_msg, linter) + expect_lint("c(1:sum(x))", const_msg, linter) # this is slightly different if a,b are factors, in which case : does # something like interaction expect_lint("c(a:b)", NULL, linter) + expect_lint("c(a:b)", expr_msg, linter_strict) expect_lint("c(a:foo(b))", NULL, linter) - expect_lint( - "c(a:b)", - "Unneeded concatenation of a simple expression", - unnecessary_concatenation_linter(allow_single_expression = FALSE) - ) - expect_lint( - "c(a:foo(b))", - "Unneeded concatenation of a simple expression", - unnecessary_concatenation_linter(allow_single_expression = FALSE) - ) + expect_lint("c(a:foo(b))", expr_msg, linter_strict) }) test_that("c(...) does not lint under !allow_single_expression", { diff --git a/tests/testthat/test-unnecessary_lambda_linter.R b/tests/testthat/test-unnecessary_lambda_linter.R index 4036e6839..9a9839bb9 100644 --- a/tests/testthat/test-unnecessary_lambda_linter.R +++ b/tests/testthat/test-unnecessary_lambda_linter.R @@ -167,8 +167,6 @@ test_that("unnecessary_lambda_linter doesn't apply to keyword args", { test_that("purrr-style anonymous functions are also caught", { linter <- unnecessary_lambda_linter() - # TODO(michaelchirico): this is just purrr::flatten(x). We should write another - # linter to encourage that usage. expect_lint("purrr::map(x, ~.x)", NULL, linter) expect_lint("purrr::map_df(x, ~lm(y, .x))", NULL, linter) expect_lint("map_dbl(x, ~foo(bar = .x))", NULL, linter) @@ -261,3 +259,19 @@ test_that("function shorthand is handled", { unnecessary_lambda_linter() ) }) + +test_that("lints vectorize", { + expect_lint( + trim_some("{ + sapply(x, function(xi) sd(xi)) + lapply(y, function(yi) { + sum(yi) + }) + }"), + list( + list("sd", line_number = 2L), + list("sum", line_number = 3L) + ), + unnecessary_lambda_linter() + ) +}) diff --git a/tests/testthat/test-unnecessary_nested_if_linter.R b/tests/testthat/test-unnecessary_nested_if_linter.R index f5b87a68e..8308b2791 100644 --- a/tests/testthat/test-unnecessary_nested_if_linter.R +++ b/tests/testthat/test-unnecessary_nested_if_linter.R @@ -1,5 +1,14 @@ +test_that("unnecessary_nested_if_linter generates deprecation warning", { + expect_warning( + unnecessary_nested_if_linter(), + rex::rex("unnecessary_nested_if_linter was deprecated", anything, "Use unnecessary_nesting_linter") + ) +}) + test_that("unnecessary_nested_if_linter skips allowed usages", { - linter <- unnecessary_nested_if_linter() + expect_warning({ + linter <- unnecessary_nested_if_linter() + }) expect_lint( trim_some(" @@ -174,7 +183,9 @@ test_that("unnecessary_nested_if_linter skips allowed usages", { test_that("unnecessary_nested_if_linter blocks disallowed usages", { lint_message <- rex::rex("Don't use nested `if` statements") - linter <- unnecessary_nested_if_linter() + expect_warning({ + linter <- unnecessary_nested_if_linter() + }) expect_lint( trim_some(" diff --git a/tests/testthat/test-unnecessary_nesting_linter.R b/tests/testthat/test-unnecessary_nesting_linter.R index 5180384a8..a1114e965 100644 --- a/tests/testthat/test-unnecessary_nesting_linter.R +++ b/tests/testthat/test-unnecessary_nesting_linter.R @@ -2,131 +2,143 @@ test_that("unnecessary_nesting_linter skips allowed usages", { linter <- unnecessary_nesting_linter() # parallel stops() and return()s are OK - double_stop_lines <- c( - "if (A) {", - " stop()", - "} else {", - " stop()", - "}" - ) - expect_lint(double_stop_lines, NULL, linter) - - double_return_lines <- c( - "if (A) {", - " return()", - "} else {", - " return()", - "}" - ) - expect_lint(double_return_lines, NULL, linter) + expect_lint( + trim_some(" + if (A) { + stop() + } else { + stop() + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (A) { + return() + } else { + return() + } + "), + NULL, + linter + ) }) -# TODO(michaelchirico): consider if there's a nice easy pattern to enforce for -# multiple if/else cases. This test in particular would be easy to un-nest, -# but it's not true in general. test_that("Multiple if/else statements don't require unnesting", { # with further branches, reducing nesting might be less readable - if_else_if_else_lines <- c( - "if (x == 'a') {", - " stop()", - "} else if (x == 'b') {", - " do_b()", - "} else {", - " stop()", - "}" - ) - expect_lint(if_else_if_else_lines, NULL, unnecessary_nesting_linter()) + expect_lint( + trim_some(" + if (x == 'a') { + stop() + } else if (x == 'b') { + do_b() + } else { + stop() + } + "), + NULL, + unnecessary_nesting_linter() + ) }) test_that("else-less if statements don't lint", { - multi_statement_if_lines <- c( - "if (x == 4) {", - " msg <- 'failed'", - " stop(msg)", - "}" + expect_lint( + trim_some(" + if (x == 4) { + msg <- 'failed' + stop(msg) + } + "), + NULL, + unnecessary_nesting_linter() ) - expect_lint(multi_statement_if_lines, NULL, unnecessary_nesting_linter()) }) test_that("non-terminal expressions are not considered for the logic", { - multi_statement_if_lines <- c( - "if (x == 4) {", - " x <- 5", - " return(x)", - "} else {", - " return(x)", - "}" - ) - expect_lint(multi_statement_if_lines, NULL, unnecessary_nesting_linter()) + expect_lint( + trim_some(" + if (x == 4) { + x <- 5 + return(x) + } else { + return(x) + } + "), + NULL, + unnecessary_nesting_linter() + ) }) test_that("parallels in further nesting are skipped", { - terminal_if_else_lines <- c( - "if (length(bucket) > 1) {", - " return(age)", - "} else {", - " if (grepl('[0-9]', age)) {", - " return(age)", - " } else {", - " return('unknown')", - " }", - "}" - ) - expect_lint(terminal_if_else_lines, NULL, unnecessary_nesting_linter()) + expect_lint( + trim_some(" + if (length(bucket) > 1) { + return(age) + } else { + age <- age / 2 + if (grepl('[0-9]', age)) { + return(age) + } else { + return('unknown') + } + } + "), + NULL, + unnecessary_nesting_linter() + ) }) test_that("unnecessary_nesting_linter blocks if/else with one exit branch", { linter <- unnecessary_nesting_linter() - if_stop_lines <- c( - "if (A) {", - " stop()", - "} else {", - " B", - "}" - ) expect_lint( - if_stop_lines, + trim_some(" + if (A) { + stop() + } else { + B + } + "), rex::rex("Reduce the nesting of this if/else statement by unnesting the portion"), linter ) - if_return_lines <- c( - "if (A) {", - " return()", - "} else {", - " B", - "}" - ) expect_lint( - if_return_lines, + trim_some(" + if (A) { + return() + } else { + B + } + "), rex::rex("Reduce the nesting of this if/else statement by unnesting the portion"), linter ) # also find exits in the later branch - else_stop_lines <- c( - "if (A) {", - " B", - "} else {", - " stop()", - "}" - ) expect_lint( - else_stop_lines, + trim_some(" + if (A) { + B + } else { + stop() + } + "), rex::rex("Reduce the nesting of this if/else statement by unnesting the portion"), linter ) - else_return_lines <- c( - "if (A) {", - " B", - "} else {", - " return()", - "}" - ) expect_lint( - else_return_lines, + trim_some(" + if (A) { + B + } else { + return() + } + "), rex::rex("Reduce the nesting of this if/else statement by unnesting the portion"), linter ) @@ -135,68 +147,89 @@ test_that("unnecessary_nesting_linter blocks if/else with one exit branch", { test_that("unnecessary_nesting_linter skips one-line functions", { linter <- unnecessary_nesting_linter() - anonymous_function_lines <- c( - "foo <- function(x) {", - " return(x)", - "}" + expect_lint( + trim_some(" + foo <- function(x) { + return(x) + } + "), + NULL, + linter ) - expect_lint(anonymous_function_lines, NULL, linter) # purrr anonymous functions also get skipped - purrr_function_lines <- c( - "purrr::map(x, ~ {", - " .x", - "})" + expect_lint( + trim_some(" + purrr::map(x, ~ { + .x + }) + "), + NULL, + linter ) - expect_lint(purrr_function_lines, NULL, linter) }) test_that("unnecessary_nesting_linter skips one-expression for loops", { linter <- unnecessary_nesting_linter() - for_lines <- c( - "for (i in 1:10) {", - " print(i)", - "}" + expect_lint( + trim_some(" + for (i in 1:10) { + print(i) + } + "), + NULL, + linter ) - expect_lint(for_lines, NULL, linter) # also for extended control flow functionality from packages - foreach_lines <- c( - "foreach (i = 1:10) %dopar% {", - " print(i)", - "}" + expect_lint( + trim_some(" + foreach (i = 1:10) %dopar% { + print(i) + } + "), + NULL, + linter ) - expect_lint(foreach_lines, NULL, linter) }) test_that("unnecessary_nesting_linter skips one-expression if and else clauses", { - lines <- c( - "if (TRUE) {", - " x", - "} else {", - " y", - "}" - ) - expect_lint(lines, NULL, unnecessary_nesting_linter()) + expect_lint( + trim_some(" + if (TRUE) { + x + } else { + y + } + "), + NULL, + unnecessary_nesting_linter() + ) }) test_that("unnecessary_nesting_linter skips one-expression while loops", { - lines <- c( - "while (x < 10) {", - " x <- x + 1", - "}" + expect_lint( + trim_some(" + while (x < 10) { + x <- x + 1 + } + "), + NULL, + unnecessary_nesting_linter() ) - expect_lint(lines, NULL, unnecessary_nesting_linter()) }) test_that("unnecessary_nesting_linter skips one-expression repeat loops", { - lines <- c( - "repeat {", - " x <- x + 1", - "}" + expect_lint( + trim_some(" + repeat { + x <- x + 1 + } + "), + NULL, + unnecessary_nesting_linter() ) - expect_lint(lines, NULL, unnecessary_nesting_linter()) }) test_that("unnecessary_nesting_linter skips one-expression assignments by default", { @@ -212,16 +245,19 @@ test_that("unnecessary_nesting_linter skips one-expression assignments by defaul }) test_that("unnecessary_nesting_linter passes for multi-line braced expressions", { - lines <- c( - "tryCatch(", - " {", - " foo(x)", - " bar(x)", - " },", - " error = identity", - ")" - ) - expect_lint(lines, NULL, unnecessary_nesting_linter()) + expect_lint( + trim_some(" + tryCatch( + { + foo(x) + bar(x) + }, + error = identity + ) + "), + NULL, + unnecessary_nesting_linter() + ) }) test_that("unnecessary_nesting_linter skips if unbracing won't reduce nesting", { @@ -289,7 +325,7 @@ test_that("rlang's double-brace operator is skipped", { test_that("unnecessary_nesting_linter blocks one-expression braced expressions", { expect_lint( trim_some(" - tryCatch( + tryToCatch( { foo(x) }, @@ -304,7 +340,7 @@ test_that("unnecessary_nesting_linter blocks one-expression braced expressions", test_that("unnecessary_nesting_linter allow_assignment= argument works", { expect_lint( trim_some(" - tryCatch( + tryToCatch( { idx <- foo(x) }, @@ -315,3 +351,385 @@ test_that("unnecessary_nesting_linter allow_assignment= argument works", { unnecessary_nesting_linter(allow_assignment = FALSE) ) }) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Reduce the nesting of this if/else") + + expect_lint( + trim_some("{ + if (A) { + stop('no') + } else { + 0 + } + if (B) { + stop('really no') + } else { + 1 + } + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 7L) + ), + unnecessary_nesting_linter() + ) +}) + +test_that("unnecessary_nesting_linter skips allowed usages", { + linter <- unnecessary_nesting_linter() + + expect_lint( + trim_some(" + if (x && y) { + 1L + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + for (x in 1:3) { + if (x && y) { + 1L + } + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + 1L + } else if (y) { + 2L + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + 1L + } else { + 2L + if (y) { + 3L + } + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (if (x) TRUE else FALSE) { + 1L + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + y <- x + 1L + if (y) { + 1L + } + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if ((x && y) || (if (x) TRUE else FALSE)) { + 1L + } + "), + NULL, + linter + ) + + # if there is any additional code between the inner and outer scopes, no lint + expect_lint( + trim_some(" + if (x && a) { + y <- x + 1L + if (y || b) { + 1L + } + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + if (y) { + 1L + } + y <- x + 1L + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + y <- x + 1L + if (y) { + 1L + } + y <- x + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + y <- x + 1L + { + if (y) { + 1L + } + } + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + { + y <- x + 1L + if (y) { + 1L + } + } + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + { + if (y) { + 1L + } + } + y <- x + 1L + } + "), + NULL, + linter + ) + + expect_lint( + trim_some(" + if (x) { + { + y <- x + 1L + { + if (y) { + 1L + } + } + } + } + "), + NULL, + linter + ) +}) + +test_that("unnecessary_nesting_linter blocks disallowed usages", { + lint_message <- rex::rex("Don't use nested `if` statements") + linter <- unnecessary_nesting_linter() + + expect_lint( + trim_some(" + if (x) { + if (y) { + 1L + } + } + "), + lint_message, + linter + ) + + expect_lint( + trim_some(" + if (x) { + if (y) 1L + } + "), + lint_message, + linter + ) + + expect_lint( + trim_some(" + if (x && a) { + if (y || b) { + 1L + } + } + "), + lint_message, + linter + ) + + expect_lint( + trim_some(" + if (if (x) TRUE else FALSE) { + if (y) { + 1L + } + } + "), + lint_message, + linter + ) + + expect_lint( + "if (x) if (y) 1L", + lint_message, + linter + ) + + expect_lint( + trim_some(" + for (x in 1:3) { + if (x) if (y) 1L + } + "), + lint_message, + linter + ) + + expect_lint( + trim_some(" + if (x) { + if (y) { + if (z) { + 1L + } + } + } + "), + list( + list(message = lint_message, line_number = 2L, column_number = 3L), + list(message = lint_message, line_number = 3L, column_number = 5L) + ), + linter + ) +}) + +test_that("else that can drop braces is found", { + linter <- unnecessary_nesting_linter() + lint_msg <- rex::rex("Simplify this condition by using 'else if' instead of 'else { if.") + + expect_lint( + trim_some(" + if (A) { + 1 + } else { + if (B) { + 2 + } else { + 3 + } + } + "), + list(lint_msg, line_number = 4L), + linter + ) + + expect_lint( + trim_some(" + if (A) { + 1 + } else if (B) { + 2 + } else { + if (C) { + 3 + } else { + 4 + } + } + "), + list(lint_msg, line_number = 6L), + linter + ) + + expect_lint( + trim_some(" + if (A) { + 1 + } else { + if (B) { + 2 + } else { + if (C) { + 3 + } else { + 4 + } + } + } + "), + list( + list(lint_msg, line_number = 4L), + list(lint_msg, line_number = 7L) + ), + linter + ) +}) + +patrick::with_parameters_test_that( + "default allowed functions are skipped", + expect_lint(sprintf("%s(x, {y}, z)", call), NULL, unnecessary_nesting_linter()), + call = c( + "test_that", "with_parameters_test_that", + "switch", + "try", "tryCatch", "withCallingHandlers", + "quote", "bquote", "expression", "substitute", + "observe", "observeEvent", "reactive", + "renderCachedPlot", "renderDataTable", "renderImage", "renderPlot", + "renderPrint", "renderTable", "renderText", "renderUI" + ) +) + +test_that("allow_functions= works", { + linter_default <- unnecessary_nesting_linter() + linter_foo <- unnecessary_nesting_linter(allow_functions = "foo") + expect_lint("foo(x, {y}, z)", "Reduce the nesting of this statement", linter_default) + expect_lint("foo(x, {y}, z)", NULL, linter_foo) + expect_lint("test_that('a', {y})", NULL, linter_default) + expect_lint("that_that('b', {y})", NULL, linter_foo) +}) diff --git a/tests/testthat/test-unnecessary_placeholder_linter.R b/tests/testthat/test-unnecessary_placeholder_linter.R index 229287a12..d8a1e677a 100644 --- a/tests/testthat/test-unnecessary_placeholder_linter.R +++ b/tests/testthat/test-unnecessary_placeholder_linter.R @@ -37,3 +37,19 @@ patrick::with_parameters_test_that( .test_name = names(pipes), pipe = pipes ) + +test_that("lints vectorize", { + lint_msg <- rex::rex("Don't use the placeholder (`.`) when it's not needed") + + expect_lint( + trim_some("{ + x %>% foo(.) + y %T>% bar(.) + }"), + list( + list(lint_msg, line_number = 2L), + list(lint_msg, line_number = 3L) + ), + unnecessary_placeholder_linter() + ) +}) diff --git a/tests/testthat/test-unreachable_code_linter.R b/tests/testthat/test-unreachable_code_linter.R index dfd57dffc..167909d50 100644 --- a/tests/testthat/test-unreachable_code_linter.R +++ b/tests/testthat/test-unreachable_code_linter.R @@ -9,7 +9,7 @@ test_that("unreachable_code_linter works in simple function", { test_that("unreachable_code_linter works in sub expressions", { linter <- unreachable_code_linter() - msg <- rex::rex("Code and comments coming after a return() or stop()") + msg <- rex::rex("Remove code and comments coming after return() or stop()") lines <- trim_some(" foo <- function(bar) { @@ -106,7 +106,7 @@ test_that("unreachable_code_linter works in sub expressions", { test_that("unreachable_code_linter works with next and break in sub expressions", { linter <- unreachable_code_linter() - msg <- rex::rex("Code and comments coming after a `next` or `break`") + msg <- rex::rex("Remove code and comments coming after `next` or `break`") lines <- trim_some(" foo <- function(bar) { @@ -247,7 +247,7 @@ test_that("unreachable_code_linter identifies simple unreachable code", { lines, list( line_number = 3L, - message = rex::rex("Code and comments coming after a return() or stop()") + message = rex::rex("Remove code and comments coming after return() or stop()") ), unreachable_code_linter() ) @@ -263,13 +263,13 @@ test_that("unreachable_code_linter finds unreachable comments", { ") expect_lint( lines, - rex::rex("Code and comments coming after a return() or stop()"), + rex::rex("Remove code and comments coming after return() or stop()"), unreachable_code_linter() ) }) test_that("unreachable_code_linter finds expressions in the same line", { - msg <- rex::rex("Code and comments coming after a return() or stop()") + msg <- rex::rex("Remove code and comments coming after return() or stop()") linter <- unreachable_code_linter() lines <- trim_some(" @@ -297,7 +297,7 @@ test_that("unreachable_code_linter finds expressions in the same line", { }) test_that("unreachable_code_linter finds expressions and comments after comment in return line", { - msg <- rex::rex("Code and comments coming after a return() or stop()") + msg <- rex::rex("Remove code and comments coming after return() or stop()") linter <- unreachable_code_linter() lines <- trim_some(" @@ -326,7 +326,7 @@ test_that("unreachable_code_linter finds a double return", { ") expect_lint( lines, - rex::rex("Code and comments coming after a return() or stop()"), + rex::rex("Remove code and comments coming after return() or stop()"), unreachable_code_linter() ) }) @@ -341,12 +341,14 @@ test_that("unreachable_code_linter finds code after stop()", { ") expect_lint( lines, - rex::rex("Code and comments coming after a return() or stop()"), + rex::rex("Remove code and comments coming after return() or stop()"), unreachable_code_linter() ) }) test_that("unreachable_code_linter ignores code after foo$stop(), which might be stopping a subprocess, for example", { + linter <- unreachable_code_linter() + expect_lint( trim_some(" foo <- function(x) { @@ -356,7 +358,7 @@ test_that("unreachable_code_linter ignores code after foo$stop(), which might be } "), NULL, - unreachable_code_linter() + linter ) expect_lint( trim_some(" @@ -367,15 +369,18 @@ test_that("unreachable_code_linter ignores code after foo$stop(), which might be } "), NULL, - unreachable_code_linter() + linter ) }) test_that("unreachable_code_linter ignores terminal nolint end comments", { + linter <- unreachable_code_linter() + withr::local_options(list( lintr.exclude_start = "#\\s*TestNoLintStart", lintr.exclude_end = "#\\s*TestNoLintEnd" )) + expect_lint( trim_some(" foo <- function() { @@ -387,7 +392,7 @@ test_that("unreachable_code_linter ignores terminal nolint end comments", { } "), NULL, - list(unreachable_code_linter(), one_linter = assignment_linter()) + list(linter, one_linter = assignment_linter()) ) expect_lint( @@ -401,13 +406,13 @@ test_that("unreachable_code_linter ignores terminal nolint end comments", { } "), NULL, - unreachable_code_linter() + linter ) }) test_that("unreachable_code_linter identifies unreachable code in conditional loops", { linter <- unreachable_code_linter() - msg <- rex::rex("Code inside a conditional loop with a deterministically false condition should be removed.") + msg <- rex::rex("Remove code inside a conditional loop with a deterministically false condition.") lines <- trim_some(" foo <- function(bar) { @@ -418,7 +423,7 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo } ") - expect_lint(lines, list(line_number = 3L, message = msg), linter) + expect_lint(lines, list(line_number = 2L, message = msg), linter) lines <- trim_some(" foo <- function(bar) { @@ -430,7 +435,7 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo } ") - expect_lint(lines, list(line_number = 4L, message = msg), linter) + expect_lint(lines, list(line_number = 2L, message = msg), linter) lines <- trim_some(" foo <- function(bar) { @@ -444,7 +449,7 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo } ") - expect_lint(lines, list(line_number = 6L, message = msg), linter) + expect_lint(lines, list(line_number = 4L, message = msg), linter) lines <- trim_some(" foo <- function(bar) { @@ -455,7 +460,7 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo } ") - expect_lint(lines, list(line_number = 3L, message = msg), linter) + expect_lint(lines, list(line_number = 2L, message = msg), linter) lines <- trim_some(" foo <- function(bar) { @@ -467,13 +472,13 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo } ") - expect_lint(lines, list(line_number = 4L, message = msg), linter) + expect_lint(lines, list(line_number = 2L, message = msg), linter) lines <- "while (FALSE) x <- 3" expect_lint( lines, - list(line_number = 1L, ranges = list(c(15L, 20L)), message = msg), + list(line_number = 1L, ranges = list(c(1L, 20L)), message = msg), linter ) @@ -481,14 +486,14 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo expect_lint( lines, - list(line_number = 1L, ranges = list(c(12L, 17L)), message = msg), + list(line_number = 1L, ranges = list(c(1L, 17L)), message = msg), linter ) }) test_that("unreachable_code_linter identifies unreachable code in conditional loops", { linter <- unreachable_code_linter() - msg <- rex::rex("Code inside an else block after a deterministically true if condition should be removed.") + msg <- rex::rex("Remove code inside an else block after a deterministically true condition.") lines <- trim_some(" foo <- function(bar) { @@ -516,10 +521,8 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo expect_lint(lines, list(line_number = 4L, message = msg), linter) - lines <- "if (TRUE) x <- 3 else if (bar) x + 3" - expect_lint( - lines, + "if (TRUE) x <- 3 else if (bar) x + 3", list(line_number = 1L, ranges = list(c(23L, 36L)), message = msg), linter ) @@ -527,52 +530,43 @@ test_that("unreachable_code_linter identifies unreachable code in conditional lo test_that("unreachable_code_linter identifies unreachable code in mixed conditional loops", { linter <- unreachable_code_linter() - msg <- rex::rex("Code inside a conditional loop with a deterministically false condition should be removed.") - - lines <- trim_some(" - function (bla) { - if (FALSE) { - code + 4 - } - while (FALSE) { - code == 3 - } - if (TRUE) { - } else { - code + bla - } - stop('.') - code <- 1 - } - ") + false_msg <- rex::rex("Remove code inside a conditional loop with a deterministically false condition.") + true_msg <- rex::rex("Remove code inside an else block after a deterministically true condition.") expect_lint( - lines, + trim_some(" + function (bla) { + if (FALSE) { + code + 4 + } + while (FALSE) { + code == 3 + } + if (TRUE) { + } else { + code + bla + } + stop('.') + code <- 1 + } + "), list( - list(line_number = 3L, message = msg), - list(line_number = 6L, message = msg), - list( - line_number = 10L, - message = rex::rex("Code inside an else block after a deterministically true if condition should be removed.") - ), - list( - line_number = 13L, - message = rex::rex("Code and comments coming after a return() or stop()") - ) + list(false_msg, line_number = 2L), + list(false_msg, line_number = 5L), + list(true_msg, line_number = 10L), + list(rex::rex("Remove code and comments coming after return() or stop()."), line_number = 13L) ), linter ) - lines <- "if (FALSE) x <- 3 else if (TRUE) x + 3 else x + 4" - expect_lint( - lines, + "if (FALSE) x <- 3 else if (TRUE) x + 3 else x + 4", list( - list(line_number = 1L, ranges = list(c(12L, 17L)), message = msg), + list(false_msg, line_number = 1L, ranges = list(c(1L, 49L))), list( + rex::rex("Remove code inside an else block after a deterministically true condition."), line_number = 1L, - ranges = list(c(45L, 49L)), - message = rex::rex("Code inside an else block after a deterministically true if condition should be removed.") + ranges = list(c(45L, 49L)) ) ), linter @@ -591,7 +585,7 @@ test_that("function shorthand is handled", { "), list( line_number = 3L, - message = rex::rex("Code and comments coming after a return() or stop()") + message = rex::rex("Remove code and comments coming after return() or stop()") ), unreachable_code_linter() ) @@ -599,71 +593,130 @@ test_that("function shorthand is handled", { test_that("Do not lint inline else after stop", { + expect_lint("if (x > 3L) stop() else x + 3", NULL, unreachable_code_linter()) +}) + +test_that("Do not lint inline else after stop in inline function", { + linter <- unreachable_code_linter() + + expect_lint("function(x) if (x > 3L) stop() else x + 3", NULL, linter) + expect_lint("function(x) if (x > 3L) { stop() } else {x + 3}", NULL, linter) +}) + +test_that("Do not lint inline else after stop in inline lambda function", { + skip_if_not_r_version("4.1.0") + + linter <- unreachable_code_linter() + + expect_lint("\\(x) if (x > 3L) stop() else x + 3", NULL, linter) + expect_lint("\\(x){ if (x > 3L) stop() else x + 3 }", NULL, linter) +}) + +test_that("allow_comment_regex= works", { + withr::local_options(c(lintr.exclude_end = "#\\s*TestNoLintEnd")) + + linter_covr <- unreachable_code_linter() + linter_xxxx <- unreachable_code_linter(allow_comment_regex = "#.*xxxx") + linter_x1x2 <- unreachable_code_linter(allow_comment_regex = c("#x", "#y")) + expect_lint( - "if (x > 3L) stop() else x + 3", + trim_some(" + function() { + return(1) + # nocov end + } + "), NULL, - unreachable_code_linter() + linter_covr ) -}) -test_that("Do not lint inline else after stop in inline function", { + expect_lint( + trim_some(" + function() { + return(1) + # TestNoLintEnd + # nocov end + } + "), + NULL, + linter_covr + ) expect_lint( - "function(x) if (x > 3L) stop() else x + 3", + trim_some(" + function() { + return(1) + # ABCDxxxx + } + "), NULL, - unreachable_code_linter() + linter_xxxx ) expect_lint( - "function(x) if (x > 3L) { stop() } else {x + 3}", + trim_some(" + function() { + return(1) + # TestNoLintEnd + # ABCDxxxx + } + "), NULL, - unreachable_code_linter() + linter_xxxx ) -}) -test_that("Do not lint inline else after stop in inline lambda function", { - skip_if_not_r_version("4.1.0") + expect_lint( + trim_some(" + function() { + return(1) + #x + } + "), + NULL, + linter_x1x2 + ) expect_lint( - "\\(x) if (x > 3L) stop() else x + 3", + trim_some(" + function() { + return(1) + #xABC + #yDEF + } + "), NULL, - unreachable_code_linter() + linter_x1x2 ) }) -test_that("Do not lint inline else after stop in lambda function", { - skip_if_not_r_version("4.1.0") +test_that("allow_comment_regex= obeys covr's custom exclusion when set", { + withr::local_options(c( + lintr.exclude_end = "#\\s*TestNoLintEnd", + covr.exclude_end = "#\\s*TestNoCovEnd" + )) + + linter_covr <- unreachable_code_linter() expect_lint( - "\\(x){ if (x > 3L) stop() else x + 3 }", + trim_some(" + function() { + return(1) + # TestNoCovEnd + } + "), NULL, - unreachable_code_linter() + linter_covr ) -}) -# nolint start: commented_code_linter. -# TODO(michaelchirico): extend to work on switch() statements -# test_that("unreachable_code_linter interacts with switch() as expected", { -# unreachable_inside_switch_lines <- trim_some(" -# foo <- function(x) { -# switch(x, -# a = { -# return(x) -# x + 1 -# }, -# b = { -# return(x + 1) -# } -# ) -# } -# ") -# expect_lint( -# unreachable_inside_switch_lines, -# rex::rex("Code and comments coming after a return() or stop()"), -# unreachable_code_linter() -# ) -# }) -# nolint end: commented_code_linter. - -# TODO(michaelchirico): This could also apply to cases without -# explicit returns (where it can only apply to comments) + expect_lint( + trim_some(" + function() { + return(1) + # TestNoLintEnd + # TestNoCovEnd + } + "), + NULL, + linter_covr + ) +}) diff --git a/tests/testthat/test-unused_import_linter.R b/tests/testthat/test-unused_import_linter.R index bb48a2cca..cb6f89872 100644 --- a/tests/testthat/test-unused_import_linter.R +++ b/tests/testthat/test-unused_import_linter.R @@ -18,7 +18,7 @@ test_that("unused_import_linter lints as expected", { expect_lint("library(dplyr, character.only = TRUE)\n1 + 1", NULL, linter) lint_msg <- rex::rex("Package 'dplyr' is attached but never used") - msg_ns <- rex::rex("Package 'dplyr' is only used by namespace") + msg_ns <- rex::rex("Don't attach package 'dplyr', which is only used by namespace.") expect_lint("library(dplyr)\n1 + 1", lint_msg, linter) expect_lint("require(dplyr)\n1 + 1", lint_msg, linter) @@ -42,8 +42,8 @@ test_that("unused_import_linter handles message vectorization", { xmlparsedata::xml_parse_data(parse(text = 'a')) "), list( - rex::rex("Package 'crayon' is attached but never used."), - rex::rex("Package 'xmlparsedata' is only used by namespace") + list(rex::rex("Package 'crayon' is attached but never used."), line_number = 1L), + list(rex::rex("Don't attach package 'xmlparsedata', which is only used by namespace"), line_number = 2L) ), unused_import_linter() ) diff --git a/tests/testthat/test-vector_logic_linter.R b/tests/testthat/test-vector_logic_linter.R index 1afb95e3e..6afaafbd4 100644 --- a/tests/testthat/test-vector_logic_linter.R +++ b/tests/testthat/test-vector_logic_linter.R @@ -28,66 +28,164 @@ test_that("vector_logic_linter skips allowed usages", { }) test_that("vector_logic_linter blocks simple disallowed usages", { - expect_lint( - "if (TRUE & FALSE) 1", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() - ) + linter <- vector_logic_linter() - expect_lint( - "while (TRUE | TRUE) 2", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() - ) + expect_lint("if (TRUE & FALSE) 1", rex::rex("Use `&&` in conditional expressions."), linter) + expect_lint("while (TRUE | TRUE) 2", rex::rex("Use `||` in conditional expressions."), linter) }) test_that("vector_logic_linter detects nested conditions", { + linter <- vector_logic_linter() + expect_lint( "if (TRUE & TRUE || FALSE) 4", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() + list(rex::rex("Use `&&` in conditional expressions."), column_number = 10L), + linter ) - expect_lint( "if (TRUE && (TRUE | FALSE)) 4", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() + list(rex::rex("Use `||` in conditional expressions."), column_number = 19L), + linter ) }) test_that("vector_logic_linter catches usages in expect_true()/expect_false()", { + linter <- vector_logic_linter() + and_msg <- rex::rex("Use `&&` in conditional expressions.") + or_msg <- rex::rex("Use `||` in conditional expressions.") + + expect_lint("expect_true(TRUE & FALSE)", and_msg, linter) + expect_lint("expect_false(TRUE | TRUE)", or_msg, linter) + + # ditto with namespace qualification + expect_lint("testthat::expect_true(TRUE & FALSE)", and_msg, linter) + expect_lint("testthat::expect_false(TRUE | TRUE)", or_msg, linter) +}) + +test_that("vector_logic_linter doesn't get mixed up from complex usage", { expect_lint( - "expect_true(TRUE & FALSE)", - rex::rex("Conditional expressions require scalar logical operators"), + trim_some(" + if (a) { + expect_true(ok) + x <- 2 + a | b + } + "), + NULL, vector_logic_linter() ) +}) +test_that("vector_logic_linter recognizes some false positves around bitwise &/|", { + linter <- vector_logic_linter() + + expect_lint("if (info & as.raw(12)) { }", NULL, linter) + expect_lint("if (as.raw(12) & info) { }", NULL, linter) + expect_lint("if (info | as.raw(12)) { }", NULL, linter) + expect_lint("if (info & as.octmode('100')) { }", NULL, linter) + expect_lint("if (info | as.octmode('011')) { }", NULL, linter) + expect_lint("if (info & as.hexmode('100')) { }", NULL, linter) + expect_lint("if (info | as.hexmode('011')) { }", NULL, linter) + # implicit as.octmode() coercion + expect_lint("if (info & '100') { }", NULL, linter) + expect_lint("if (info | '011') { }", NULL, linter) + expect_lint("if ('011' | info) { }", NULL, linter) + + # further nesting + expect_lint("if ((info & as.raw(12)) == as.raw(12)) { }", NULL, linter) + expect_lint("if ((info | as.raw(12)) == as.raw(12)) { }", NULL, linter) + expect_lint('if ((mode & "111") != as.octmode("111")) { }', NULL, linter) + expect_lint('if ((mode | "111") != as.octmode("111")) { }', NULL, linter) + expect_lint('if ((mode & "111") != as.hexmode("111")) { }', NULL, linter) + expect_lint('if ((mode | "111") != as.hexmode("111")) { }', NULL, linter) +}) + +test_that("incorrect subset/filter usage is caught", { + linter <- vector_logic_linter() + and_msg <- rex::rex("Use `&` in subsetting expressions") + or_msg <- rex::rex("Use `|` in subsetting expressions") + + expect_lint("filter(x, y && z)", and_msg, linter) + expect_lint("filter(x, y || z)", or_msg, linter) + expect_lint("subset(x, y && z)", and_msg, linter) + expect_lint("subset(x, y || z)", or_msg, linter) + + expect_lint("x %>% filter(y && z)", and_msg, linter) + expect_lint("filter(x, a & b, c | d, e && f)", list(and_msg, column_number = 27L), linter) +}) + +test_that("native pipe usage is caught in subset/filter logic", { + skip_if_not_r_version("4.1.0") + + expect_lint("x |> filter(y && z)", rex::rex("Use `&` in subsetting"), vector_logic_linter()) +}) + +test_that("subsetting logic handles nesting", { + linter <- vector_logic_linter() + and_msg <- rex::rex("Use `&` in subsetting expressions") + or_msg <- rex::rex("Use `|` in subsetting expressions") + + expect_lint("filter(x, a & b || c)", or_msg, linter) + expect_lint("filter(x, a && b | c)", and_msg, linter) + + # but not valid usage + expect_lint("filter(x, y < mean(y, na.rm = AA && BB))", NULL, linter) + expect_lint("subset(x, y < mean(y, na.rm = AA && BB) & y > 0)", NULL, linter) + expect_lint("subset(x, y < x[y > 0, drop = AA && BB, y])", NULL, linter) +}) + +test_that("filter() handling is conservative about stats::filter()", { + linter <- vector_logic_linter() + and_msg <- rex::rex("Use `&` in subsetting expressions") + + # NB: this should be invalid, filter= is a vector argument + expect_lint("stats::filter(x, y && z)", NULL, linter) + # The only logical argument to stats::filter(), exclude by keyword + expect_lint("filter(x, circular = y && z)", NULL, linter) + # But presence of circular= doesn't invalidate lint + expect_lint("filter(x, circular = TRUE, y && z)", and_msg, linter) + expect_lint("filter(x, y && z, circular = TRUE)", and_msg, linter) expect_lint( - "expect_false(TRUE | TRUE)", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() + trim_some(" + filter(x, circular # comment + = y && z) + "), + NULL, + linter ) - - # ditto with namespace qualification expect_lint( - "testthat::expect_true(TRUE & FALSE)", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() + trim_some(" + filter(x, circular = # comment + y && z) + "), + NULL, + linter ) - expect_lint( - "testthat::expect_false(TRUE | TRUE)", - rex::rex("Conditional expressions require scalar logical operators"), - vector_logic_linter() + trim_some(" + filter(x, circular # comment + = # comment + y && z) + "), + NULL, + linter ) }) -test_that("vector_logic_linter doesn't get mixed up from complex usage", { - lines <- trim_some(" - if (a) { - expect_true(ok) - x <- 2 - a | b - }") - expect_lint(lines, NULL, vector_logic_linter()) +test_that("lints vectorize", { + expect_lint( + trim_some("{ + if (AA & BB) {} + if (CC | DD) {} + filter(x, EE && FF) + subset(y, GG || HH) + }"), + list( + list(rex::rex("`&&`"), line_number = 2L), + list(rex::rex("`||`"), line_number = 3L), + list(rex::rex("`&`"), line_number = 4L), + list(rex::rex("`|`"), line_number = 5L) + ), + vector_logic_linter() + ) }) diff --git a/tests/testthat/test-with.R b/tests/testthat/test-with.R index 6b4fc00a8..0e9a7f7e6 100644 --- a/tests/testthat/test-with.R +++ b/tests/testthat/test-with.R @@ -22,11 +22,15 @@ test_that("linters_with_defaults warns on unused NULLs", { }) test_that("linters_with_tags() verifies the output of available_linters()", { - skip_if_not_installed("mockery") - mockery::stub( - linters_with_tags, - "available_linters", - data.frame(linter = c("fake_linter", "very_fake_linter"), package = "lintr", tags = "", stringsAsFactors = FALSE) + local_mocked_bindings( + available_linters = function(...) { + data.frame( + linter = c("fake_linter", "very_fake_linter"), + package = "lintr", + tags = "", + stringsAsFactors = FALSE + ) + } ) expect_error( linters_with_tags(NULL), diff --git a/tests/testthat/test-yoda_test_linter.R b/tests/testthat/test-yoda_test_linter.R index 2cd48fc03..812440d9e 100644 --- a/tests/testthat/test-yoda_test_linter.R +++ b/tests/testthat/test-yoda_test_linter.R @@ -1,40 +1,31 @@ test_that("yoda_test_linter skips allowed usages", { - expect_lint("expect_equal(x, 2)", NULL, yoda_test_linter()) + linter <- yoda_test_linter() + + expect_lint("expect_equal(x, 2)", NULL, linter) # namespace qualification doesn't matter - expect_lint("testthat::expect_identical(x, 'a')", NULL, yoda_test_linter()) + expect_lint("testthat::expect_identical(x, 'a')", NULL, linter) # two variables can't be distinguished which is expected/actual (without # playing quixotic games trying to parse that out from variable names) - expect_lint("expect_equal(x, y)", NULL, yoda_test_linter()) + expect_lint("expect_equal(x, y)", NULL, linter) }) test_that("yoda_test_linter blocks simple disallowed usages", { - expect_lint( - "expect_equal(2, x)", - rex::rex("Tests should compare objects in the order 'actual', 'expected'"), - yoda_test_linter() - ) - expect_lint( - "testthat::expect_identical('a', x)", - rex::rex("Tests should compare objects in the order 'actual', 'expected'"), - yoda_test_linter() - ) - expect_lint( - "expect_setequal(2, x)", - rex::rex("Tests should compare objects in the order 'actual', 'expected'"), - yoda_test_linter() - ) + linter <- yoda_test_linter() + lint_msg <- rex::rex("Compare objects in tests in the order 'actual', 'expected', not the reverse.") + + expect_lint("expect_equal(2, x)", lint_msg, linter) + expect_lint("testthat::expect_identical('a', x)", lint_msg, linter) + expect_lint("expect_setequal(2, x)", lint_msg, linter) # complex literals are slightly odd - expect_lint( - "expect_equal(2 + 1i, x)", - rex::rex("Tests should compare objects in the order 'actual', 'expected'"), - yoda_test_linter() - ) + expect_lint("expect_equal(2 + 1i, x)", lint_msg, linter) }) test_that("yoda_test_linter ignores strings in $ expressions", { + linter <- yoda_test_linter() + # the "key" here shows up at the same level of the parse tree as plain "key" normally would - expect_lint('expect_equal(x$"key", 2)', NULL, yoda_test_linter()) - expect_lint('expect_equal(x@"key", 2)', NULL, yoda_test_linter()) + expect_lint('expect_equal(x$"key", 2)', NULL, linter) + expect_lint('expect_equal(x@"key", 2)', NULL, linter) }) # if we only inspect the first argument & ignore context, get false positives @@ -57,14 +48,16 @@ test_that("yoda_test_linter throws a special message for placeholder tests", { ) }) -# TODO(michaelchirico): Should this be extended to RUnit tests? It seems yes, -# but the argument names in RUnit (inherited from base all.equal()) are a bit -# confusing, e.g. `checkEqual(target=, current=)`. From the name, one might -# reasonably conclude 'expected' comes first, and 'actual' comes second. -# TODO(michaelchirico): What sorts of combinations of literals can be included? -# e.g. expect_equal(c(1, 2), x) is a yoda test; is expect_equal(c(x, 1), y)? -# clearly it's not true for general f() besides c(). What about other -# constructors of literals? data.frame(), data.table(), tibble(), ...? -# TODO(michaelchirico): The logic could also be extended to "tests" inside regular -# code, not just test suites, e.g. `if (2 == x)`, `while(3 <= x)`, -# `stopifnot('a' == foo(y))`. +test_that("lints vectorize", { + expect_lint( + trim_some("{ + expect_equal(1, 1) + expect_equal(2, foo(x)) + }"), + list( + list("Avoid storing placeholder tests", line_number = 2L), + list("Compare objects in tests in the order 'actual', 'expected'", line_number = 3L) + ), + yoda_test_linter() + ) +}) diff --git a/vignettes/continuous-integration.Rmd b/vignettes/continuous-integration.Rmd index f5763eaaa..a07478923 100644 --- a/vignettes/continuous-integration.Rmd +++ b/vignettes/continuous-integration.Rmd @@ -51,27 +51,6 @@ Note that this will kill the R process in case of a lint. If your project is in a subdirectory and you would like to use GitHub Actions annotations, you can set `options(lintr.github_annotation_project_dir = "path/to/project")` which will make sure that the annotations point to the correct paths. -### Travis CI - -If you want to run `lintr` on [Travis-CI](https://www.travis-ci.com/), you will need to have Travis install the package first. -This can be done by adding the following line to your `.travis.yml` - -``` yaml -r_github_packages: - - r-lib/lintr -``` - -We recommend running `lintr::lint_package()` as an after_success step in your build process: - -``` yaml -after_success: - - R CMD INSTALL $PKG_TARBALL - - Rscript -e 'lintr::lint_package()' -``` - -If lints are found in the commit or pull request they will be printed on Travis-CI. -The environment variable `LINTR_ERROR_ON_LINT` mentioned for GitHub actions also works with Travis CI builds. - ## For projects You are not limited to using `lintr` for packages -- you can use it in combination with continuous integration for any other project. diff --git a/vignettes/creating_linters.Rmd b/vignettes/creating_linters.Rmd index b967e8029..d4025848e 100644 --- a/vignettes/creating_linters.Rmd +++ b/vignettes/creating_linters.Rmd @@ -256,7 +256,7 @@ expect_lint("blah=1; blah=2", list( list(line_number = 1, column_number = 5), list(line_number = 1, column_number = 13), - ) + ), assignment_linter() ) ``` @@ -274,6 +274,26 @@ and so they've been tested and demonstrated their utility already. extract the string exactly as R will see it. This is especially important to make your logic robust to R-4-style raw strings like `R"-(hello)-"`, which is otherwise difficult to express, for example as an XPath. + * `xml_find_function_calls()`: Whenever your linter needs to query R function calls, + e.g. via the XPath `//SYMBOL_FUNCTION_CALL[text() = 'myfun']`, use this member of + `source_expression` to obtain the function call nodes more efficiently. + Instead of + ```r + xml <- source_expression$xml_parsed_content + xpath <- "//SYMBOL_FUNCTION_CALL[text() = 'myfun']/parent::expr/some/cond" + xml_find_all(xml, xpath) + ``` + use + ```r + xml_calls <- source_expression$xml_find_function_calls("myfun") + call_xpath <- "parent::expr/some/cond" + xml_find_all(xml_calls, call_xpath) + ``` + * `make_linter_from_xpath()` and `make_linter_from_function_xpath()`: Whenever your + linter can be expressed by a static XPath and a static message, use `make_linter_from_xpath()` + or, if the XPath starts with `//SYMBOL_FUNCTION_CALL`, use `make_linter_from_function_xpath()`. + Instead of `make_linter_from_xpath(xpath = "//SYMBOL_FUNCTION_CALL[text() = 'foo' or text() = 'bar']/cond")`, + use `make_linter_from_function_xpath(function_names = c("foo", "bar"), xpath = "cond")`. ## Contributing to `{lintr}`