Merge branch 'master' into redundant_ifelse

# Conflicts:
#	DESCRIPTION
#	NAMESPACE
#	inst/lintr/linters.csv
#	man/best_practices_linters.Rd
#	man/efficiency_linters.Rd
#	man/linters.Rd

Author: MichaelChirico

DESCRIPTION

@@ -113,13 +113,15 @@ Collate:
     'pipe_call_linter.R'
     'pipe_continuation_linter.R'
     'redundant_ifelse_linter.R'
+    'regex_subset_linter.R'
     'semicolon_terminator_linter.R'
     'seq_linter.R'
     'settings.R'
     'single_quotes_linter.R'
     'spaces_inside_linter.R'
     'spaces_left_parentheses_linter.R'
     'sprintf_linter.R'
+    'system_file_linter.R'
     'trailing_blank_lines_linter.R'
     'trailing_whitespace_linter.R'
     'tree-utils.R'

NAMESPACE

@@ -77,12 +77,14 @@ export(paste_sep_linter)
 export(pipe_call_linter)
 export(pipe_continuation_linter)
 export(redundant_ifelse_linter)
+export(regex_subset_linter)
 export(semicolon_terminator_linter)
 export(seq_linter)
 export(single_quotes_linter)
 export(spaces_inside_linter)
 export(spaces_left_parentheses_linter)
 export(sprintf_linter)
+export(system_file_linter)
 export(todo_comment_linter)
 export(trailing_blank_lines_linter)
 export(trailing_whitespace_linter)

NEWS.md

@@ -108,7 +108,9 @@ function calls. (#850, #851, @renkun-ken)
    * `nested_ifelse_linter()` Prevent nested calls to `ifelse()` like `ifelse(A, x, ifelse(B, y, z))`, and similar
    * `redundant_ifelse_linter()` Prevent usage like `ifelse(A & B, TRUE, FALSE)` or `ifelse(C, 0, 1)` (the latter is `as.numeric(!C)`)
    * `unreachable_code_linter()` Prevent code after `return()` and `stop()` statements that will never be reached
+   * `regex_subset_linter()` Require usage of `grep(ptn, x, value = TRUE)` over `x[grep(ptn, x)]` and similar
    * `consecutive_stopifnot_linter()` Require consecutive calls to `stopifnot()` to be unified into one
+   * `system_file_linter()` Require file paths to be constructed by `system.file()` instead of calling `file.path()` directly
 * `assignment_linter()` now lints right assignment (`->` and `->>`) and gains two arguments. `allow_cascading_assign` (`TRUE` by default) toggles whether to lint `<<-` and `->>`; `allow_right_assign` toggles whether to lint `->` and `->>` (#915, @michaelchirico)
 * `infix_spaces_linter()` gains argument `exclude_operators` to disable lints on selected infix operators. By default, all "low-precedence" operators throw lints; see `?infix_spaces_linter` for an enumeration of these. (#914 @michaelchirico)
 * `infix_spaces_linter()` now throws a lint on `a~b` and `function(a=1) {}` (#930, @michaelchirico)

R/regex_subset_linter.R

@@ -0,0 +1,87 @@
+#' Require usage of direct methods for subsetting strings via regex.
+#'
+#' Using `value = TRUE` in [grep()] returns the subset of the input that matches
+#'   the pattern, e.g. `grep("[a-m]", letters, value = TRUE)` will return the
+#'   first 13 elements (`a` through `m`).
+#'
+#' `letters[grep("[a-m]", letters)]` and `letters[grepl("[a-m]", letters)]`
+#'   both return the same thing, but more circuitously and more verbosely.
+#'
+#' The `stringr` package also provides an even more readable alternative,
+#'   namely `str_subset()`, which should be preferred to versions using
+#'   `str_detect()` and `str_which()`.
+#'
+#' @section Exceptions:
+#'   Note that `x[grep(pattern, x)]` and `grep(pattern, x, value = TRUE)`
+#'   are not _completely_ interchangeable when `x` is not character
+#'   (most commonly, when `x` is a factor), because the output of the
+#'   latter will be a character vector while the former remains a factor.
+#'   It still may be preferable to refactor such code, as it may be faster
+#'   to match the pattern on `levels(x)` and use that to subset instead.
+#'
+#' @evalRd rd_tags("regex_subset_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+regex_subset_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$xml_parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    parent_expr_cond <- xp_and(
+      "OP-LEFT-BRACKET",
+      # parent::expr for LEFT_ASSIGN and RIGHT_ASSIGN, but, strangely,
+      #   parent::equal_assign for EQ_ASSIGN. So just use * as a catchall.
+      "not(parent::*[LEFT_ASSIGN or EQ_ASSIGN or RIGHT_ASSIGN])"
+    )
+    # See https://www.w3.org/TR/1999/REC-xpath-19991116/#booleans;
+    #   equality of nodes is based on the string value of the nodes, which
+    #   is basically what we need, i.e., whatever expression comes in
+    #   <expr>[grepl(pattern, <expr>)] matches exactly, e.g. names(x)[grepl(ptn, names(x))].
+    subset_cond_fmt <- xp_and(
+      "expr[SYMBOL_FUNCTION_CALL[%s]]",
+      "expr[position() = %d] = parent::expr/expr[1]"
+    )
+    grep_xpath <- sprintf(
+      "//expr[%s]/expr[%s]",
+      parent_expr_cond,
+      sprintf(subset_cond_fmt, xp_text_in_table(c("grep", "grepl")), 3L)
+    )
+
+    grep_expr <- xml2::xml_find_all(xml, grep_xpath)
+
+    grep_lints <- lapply(
+      grep_expr,
+      xml_nodes_to_lint,
+      source_file = source_file,
+      lint_message = paste(
+        "Prefer grep(pattern, x, ..., value = TRUE) over",
+        "x[grep(pattern, x, ...)] and x[grepl(pattern, x, ...)]."
+      ),
+      type = "warning"
+    )
+
+    stringr_xpath <- sprintf(
+      "//expr[%s]/expr[%s]",
+      parent_expr_cond,
+      sprintf(subset_cond_fmt, xp_text_in_table(c("str_detect", "str_which")), 2L)
+    )
+
+    stringr_expr <- xml2::xml_find_all(xml, stringr_xpath)
+
+    stringr_lints <- lapply(
+      stringr_expr,
+      xml_nodes_to_lint,
+      source_file = source_file,
+      lint_message = paste(
+        "Prefer stringr::str_subset(x, pattern) over",
+        "x[str_detect(x, pattern)] and x[str_which(x, pattern)]."
+      ),
+      type = "warning"
+    )
+
+    return(c(grep_lints, stringr_lints))
+  })
+}

R/system_file_linter.R

@@ -0,0 +1,48 @@
+#' Block usage of file.path() with system.file()
+#'
+#' [system.file()] has a `...` argument which, internally, is passed to
+#'   [file.path()], so including it in user code is repetitive.
+#'
+#' @evalRd rd_tags("system_file_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+system_file_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$xml_parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    xpath <- "//expr[
+      (
+        expr/SYMBOL_FUNCTION_CALL[text() = 'system.file']
+        and expr/expr/SYMBOL_FUNCTION_CALL[text() = 'file.path']
+      ) or (
+        expr/SYMBOL_FUNCTION_CALL[text() = 'file.path']
+        and expr/expr/SYMBOL_FUNCTION_CALL[text() = 'system.file']
+      )
+    ]"
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    return(lapply(
+      bad_expr,
+      xml_nodes_to_lint,
+      source_file = source_file,
+      lint_message = function(expr) {
+        outer_call <- xml2::xml_text(xml2::xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL"))
+        if (outer_call == "system.file") {
+          bad_usage <- 'system.file(file.path("data", "model.csv"), package = "myrf")'
+        } else {
+          bad_usage <- 'file.path(system.file(package = "myrf"), "data", "model.csv")'
+        }
+        paste(
+          "Use the `...` argument of system.file() to expand paths,",
+          'e.g. system.file("data", "model.csv", package = "myrf") instead of',
+          bad_usage
+        )
+      },
+      type = "warning"
+    ))
+  })
+}

inst/lintr/linters.csv

@@ -50,12 +50,14 @@ paste_sep_linter,best_practices consistency
 pipe_call_linter,style readability
 pipe_continuation_linter,style readability default
 redundant_ifelse_linter,best_practices efficiency consistency
+regex_subset_linter,best_practices efficiency
 semicolon_terminator_linter,style readability default configurable
 seq_linter,robustness efficiency consistency best_practices default
 single_quotes_linter,style consistency readability default
 spaces_inside_linter,style readability default
 spaces_left_parentheses_linter,style readability default
 sprintf_linter,correctness common_mistakes
+system_file_linter,consistency readability best_practices
 T_and_F_symbol_linter,style readability robustness consistency best_practices default
 todo_comment_linter,style configurable
 trailing_blank_lines_linter,style default

man/best_practices_linters.Rd

@@ -0,0 +1,50 @@
+test_that("regex_subset_linter skips allowed usages", {
+  expect_lint("y[grepl(ptn, x)]", NULL, regex_subset_linter())
+  expect_lint("x[grepl(ptn, foo(x))]", NULL, regex_subset_linter())
+})
+
+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()
+  )
+
+  expect_lint(
+    "names(foo(y))[grepl(ptn, names(foo(y)), fixed = TRUE)]",
+    rex::rex("Prefer grep(pattern, x, ..., value = TRUE)"),
+    regex_subset_linter()
+  )
+})
+
+test_that("regex_subset_linter skips grep/grepl subassignment", {
+  expect_lint("x[grep(ptn, x)] <- ''", NULL, regex_subset_linter())
+  expect_lint("x[grepl(ptn, x)] <- ''", NULL, regex_subset_linter())
+  expect_lint("x[grep(ptn, x, perl = TRUE)] = ''", NULL, regex_subset_linter())
+  expect_lint("'' -> x[grep(ptn, x, ignore.case = TRUE)] = ''", NULL, regex_subset_linter())
+})
+
+test_that("regex_subset_linter works for stringr equivalents", {
+  expect_lint("y[str_detect(x, ptn)]", NULL, regex_subset_linter())
+  expect_lint("x[str_detect(foo(x), ptn)]", NULL, regex_subset_linter())
+
+  expect_lint(
+    "x[str_which(x, ptn)]",
+    rex::rex("Prefer stringr::str_subset(x, pattern) over"),
+    regex_subset_linter()
+  )
+
+  expect_lint(
+    "names(y)[str_detect(names(y), ptn, negate = TRUE)]",
+    rex::rex("Prefer stringr::str_subset(x, pattern) over"),
+    regex_subset_linter()
+  )
+  expect_lint("x[str_detect(x, ptn)] <- ''", NULL, regex_subset_linter())
+  expect_lint("x[str_detect(x, ptn)] <- ''", NULL, regex_subset_linter())
+})

man/consistency_linters.Rd

@@ -0,0 +1,18 @@
+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())
+})
+
+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()
+  )
+
+  expect_lint(
+    "file.path(system.file(package = 'foo'), 'path', 'to', 'data')",
+    rex::rex("Use the `...` argument of system.file() to expand paths"),
+    system_file_linter()
+  )
+})