Merge branch 'main' into require_nzchar

Author: MichaelChirico

DESCRIPTION

@@ -157,6 +157,7 @@ Collate:
     'regex_subset_linter.R'
     'repeat_linter.R'
     'routine_registration_linter.R'
+    'sample_int_linter.R'
     'scalar_in_linter.R'
     'semicolon_linter.R'
     'seq_linter.R'
@@ -167,9 +168,11 @@ Collate:
     'spaces_inside_linter.R'
     'spaces_left_parentheses_linter.R'
     'sprintf_linter.R'
+    'stopifnot_all_linter.R'
     'string_boundary_linter.R'
     'strings_as_factors_linter.R'
     'system_file_linter.R'
+    'terminal_close_linter.R'
     'trailing_blank_lines_linter.R'
     'trailing_whitespace_linter.R'
     'tree_utils.R'

NAMESPACE

@@ -120,6 +120,7 @@ export(redundant_ifelse_linter)
 export(regex_subset_linter)
 export(repeat_linter)
 export(routine_registration_linter)
+export(sample_int_linter)
 export(sarif_output)
 export(scalar_in_linter)
 export(semicolon_linter)
@@ -130,9 +131,11 @@ export(sort_linter)
 export(spaces_inside_linter)
 export(spaces_left_parentheses_linter)
 export(sprintf_linter)
+export(stopifnot_all_linter)
 export(string_boundary_linter)
 export(strings_as_factors_linter)
 export(system_file_linter)
+export(terminal_close_linter)
 export(todo_comment_linter)
 export(trailing_blank_lines_linter)
 export(trailing_whitespace_linter)

NEWS.md

@@ -6,12 +6,16 @@
 
 ### New linters
 
+* `sample_int_linter()` for encouraging `sample.int(n, ...)` over equivalents like `sample(1:n, ...)` (part of #884, @MichaelChirico).
+* `stopifnot_all_linter()` discourages tests with `all()` like `stopifnot(all(x > 0))`; `stopifnot()` runs `all()` itself, and uses a better error message (part of #884, @MichaelChirico).
 * `comparison_negation_linter()` for discouraging negated comparisons when a direct negation is preferable, e.g. `!(x == y)` could be `x != y` (part of #884, @MichaelChirico).
 * `nzchar_linter()` for encouraging `nzchar()` to test for empty strings, e.g. `nchar(x) > 0` can be `nzchar(x)` (part of #884, @MichaelChirico).
+* `terminal_close_linter()` for discouraging using `close()` to end functions (part of #884, @MichaelChirico). Such usages are not robust to errors, where `close()` will not be run as intended. Put `close()` in an `on.exit()` hook, or use {withr} to manage connections with proper cleanup.
 
 ### Lint accuracy fixes: removing false positives
 
 * `unreachable_code_linter()` ignores reachable code in inline functions like `function(x) if (x > 2) stop() else x` (#2259, @MEO265).
+* `unnecessary_lambda_linter()` ignores extractions with explicit returns like `lapply(l, function(x) foo(x)$bar)` (#2258, @MichaelChirico).
 
 # lintr 3.1.1
 

R/comparison_negation_linter.R

@@ -3,6 +3,34 @@
 #' `!(x == y)` is more readably expressed as `x != y`. The same is true of
 #'   other negations of simple comparisons like `!(x > y)` and `!(x <= y)`.
 #'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "!x == 2",
+#'   linters = comparison_negation_linter()
+#' )
+#'
+#' lint(
+#'   text = "!(x > 2)",
+#'   linters = comparison_negation_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "!(x == 2 & y > 2)",
+#'   linters = comparison_negation_linter()
+#' )
+#'
+#' lint(
+#'   text = "!(x & y)",
+#'   linters = comparison_negation_linter()
+#' )
+#'
+#' lint(
+#'   text = "x != 2",
+#'   linters = comparison_negation_linter()
+#' )
+#'
 #' @evalRd rd_tags("comparison_negation_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export

R/get_source_expressions.R

@@ -68,8 +68,7 @@ get_source_expressions <- function(filename, lines = NULL) {
   }
 
   # Only regard explicit attribute terminal_newline=FALSE as FALSE and all other cases (e.g. NULL or TRUE) as TRUE.
-  # We don't use isFALSE since it is introduced in R 3.5.0.
-  terminal_newline <- !identical(attr(source_expression$lines, "terminal_newline", exact = TRUE), FALSE)
+  terminal_newline <- !isFALSE(attr(source_expression$lines, "terminal_newline", exact = TRUE))
 
   e <- NULL
   source_expression$lines <- extract_r_source(
@@ -493,19 +492,6 @@ get_source_expression <- function(source_expression, error = identity) {
     error = error
   )
 
-  # TODO: Remove when minimum R version is bumped to > 3.5
-  #
-  # This needs to be done twice to avoid a bug fixed in R 3.4.4
-  #   https://bugs.r-project.org/bugzilla/show_bug.cgi?id=16041
-  parsed_content <- tryCatch(
-    parse(
-      text = source_expression$content,
-      srcfile = source_expression,
-      keep.source = TRUE
-    ),
-    error = error
-  )
-
   if (inherits(parsed_content, c("error", "lint"))) {
     assign("e", parsed_content, envir = parent.frame())
     parse_error <- TRUE

R/namespace.R

@@ -85,13 +85,7 @@ is_s3_generic <- function(fun) {
 
 .base_s3_generics <- unique(c(
   names(.knownS3Generics),
-  if (getRversion() >= "3.5.0") {
-    .S3_methods_table[, 1L]
-  } else {
-    # R < 3.5.0 doesn't provide .S3_methods_table
-    # fallback: search baseenv() for generic methods
-    imported_s3_generics(data.frame(pkg = "base", fun = ls(baseenv()), stringsAsFactors = FALSE))$fun
-  },
+  .S3_methods_table[, 1L],
   # Contains S3 generic groups, see ?base::groupGeneric and src/library/base/R/zzz.R
   ls(.GenericArgsEnv)
 ))

R/nonportable_path_linter.R

@@ -2,6 +2,19 @@
 #'
 #' Check that [file.path()] is used to construct safe and portable paths.
 #'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "'abcdefg/hijklmnop/qrst/uv/wxyz'",
+#'   linters = nonportable_path_linter
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "file.path('abcdefg', 'hijklmnop', 'qrst', 'uv', 'wxyz')",
+#'   linters = nonportable_path_linter()
+#' )
+#'
 #' @inheritParams absolute_path_linter
 #' @evalRd rd_tags("nonportable_path_linter")
 #' @seealso

R/sample_int_linter.R

@@ -0,0 +1,88 @@
+#' Require usage of sample.int(n, m, ...) over sample(1:n, m, ...)
+#'
+#' [sample.int()] is preferable to `sample()` for the case of sampling numbers
+#'   between 1 and `n`. `sample` calls `sample.int()` "under the hood".
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "sample(1:10, 2)",
+#'   linters = sample_int_linter()
+#' )
+#'
+#' lint(
+#'   text = "sample(seq(4), 2)",
+#'   linters = sample_int_linter()
+#' )
+#'
+#' lint(
+#'   text = "sample(seq_len(8), 2)",
+#'   linters = sample_int_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "sample(seq(1, 5, by = 2), 2)",
+#'   linters = sample_int_linter()
+#' )
+#'
+#' lint(
+#'   text = "sample(letters, 2)",
+#'   linters = sample_int_linter()
+#' )
+#'
+#' @evalRd rd_tags("sample_int_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+sample_int_linter <- function() {
+  # looking for anything like sample(1: that doesn't come after a $ extraction
+  # 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)]
+    /following-sibling::expr[1][
+      (
+        expr[1]/NUM_CONST[text() = '1' or text() = '1L']
+        and OP-COLON
+      )
+      or expr/SYMBOL_FUNCTION_CALL[text() = 'seq_len']
+      or (
+        expr/SYMBOL_FUNCTION_CALL[text() = 'seq']
+        and (
+          count(expr) = 2
+          or (
+            expr[2]/NUM_CONST[text() = '1' or text() = '1L']
+            and not(SYMBOL_SUB[
+              text() = 'by'
+              and not(following-sibling::expr[1]/NUM_CONST[text() = '1' or text() = '1L'])
+            ])
+          )
+        )
+      )
+      or NUM_CONST[not(text() = 'TRUE' or text() = 'FALSE')]
+    ]
+    /parent::expr
+  ")
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    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"
+    original[!is.na(xml_find_first(bad_expr, "expr[2]/NUM_CONST"))] <- "n"
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = glue("sample.int(n, m, ...) is preferable to sample({original}, m, ...)."),
+      type = "warning"
+    )
+  })
+}

R/scalar_in_linter.R

@@ -7,6 +7,24 @@
 #' `scalar %in% vector` is OK, because the alternative (`any(vector == scalar)`)
 #'   is more circuitous & potentially less clear.
 #'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "x %in% 1L",
+#'   linters = scalar_in_linter()
+#' )
+#'
+#' lint(
+#'   text = "x %chin% 'a'",
+#'   linters = scalar_in_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "x %in% 1:10",
+#'   linters = scalar_in_linter()
+#' )
+#'
 #' @evalRd rd_tags("scalar_in_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export

R/stopifnot_all_linter.R

@@ -0,0 +1,43 @@
+#' Block usage of all() within stopifnot()
+#'
+#' `stopifnot(A)` actually checks `all(A)` "under the hood" if `A` is a vector,
+#'   and produces a better error message than `stopifnot(all(A))` does.
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "stopifnot(all(x > 0))",
+#'   linters = stopifnot_all_linter()
+#' )
+#'
+#' lint(
+#'   text = "stopifnot(y > 3, all(x < 0))",
+#'   linters = stopifnot_all_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "stopifnot(is.null(x) || all(x > 0))",
+#'   linters = stopifnot_all_linter()
+#' )
+#'
+#' lint(
+#'   text = "assert_that(all(x > 0))",
+#'   linters = stopifnot_all_linter()
+#' )
+#'
+#' @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(
+  xpath = "
+  //SYMBOL_FUNCTION_CALL[text() = 'stopifnot']
+    /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."
+  )
+)

R/terminal_close_linter.R

@@ -0,0 +1,56 @@
+#' Prohibit close() from terminating a function definition
+#'
+#' Functions that end in `close(x)` are almost always better written by using
+#'   `on.exit(close(x))` close to where `x` is defined and/or opened.
+#'
+#' @examples
+#' # will produce lints
+#' code <- paste(
+#'   "f <- function(fl) {",
+#'   "  conn <- file(fl, open = 'r')",
+#'   "  readLines(conn)",
+#'   "  close(conn)",
+#'   "}",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = terminal_close_linter()
+#' )
+#'
+#' # okay
+#' code <- paste(
+#'   "f <- function(fl) {",
+#'   "  conn <- file(fl, open = 'r')",
+#'   "  on.exit(close(conn))",
+#'   "  readLines(conn)",
+#'   "}",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = terminal_close_linter()
+#' )
+#'
+#' @evalRd rd_tags("terminal_close_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+terminal_close_linter <- make_linter_from_xpath(
+  xpath = "
+  //FUNCTION
+    /following-sibling::expr
+    /expr[last()][
+      expr/SYMBOL_FUNCTION_CALL[text() = 'close']
+      or expr[
+        SYMBOL_FUNCTION_CALL[text() = 'return']
+        and following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'close']
+      ]
+    ]
+  ",
+  lint_message = paste(
+    "Use on.exit(close(x)) to close connections instead of",
+    "running it as the last call in a function."
+  )
+)

R/unnecessary_lambda_linter.R

@@ -63,7 +63,6 @@ unnecessary_lambda_linter <- function() {
   #     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
-  # TODO(#1703): handle explicit returns too: function(x) return(x)
   default_fun_xpath <- glue("
   //SYMBOL_FUNCTION_CALL[ {apply_funs} ]
     /parent::expr
@@ -76,8 +75,8 @@ unnecessary_lambda_linter <- function() {
           position() = 2
           and preceding-sibling::expr/SYMBOL_FUNCTION_CALL
           and not(preceding-sibling::*[1][self::EQ_SUB])
+          and not(parent::expr/following-sibling::*[not(self::OP-RIGHT-PAREN or self::OP-RIGHT-BRACE)])
         ]/SYMBOL
-      and count(OP-LEFT-PAREN) + count(OP-LEFT-BRACE/following-sibling::expr/OP-LEFT-PAREN) = 1
     ]
     /parent::expr
   ")