New coalesce_linter for encouraging %||% (#2767)

* initial work check-in

* complete first pass of linter

* delint

* Redefine our %||%-->%|||%

* land on full 'if' expression, add metadata tests

* don't need %|||% in non-package file

* Need to specify linter

* fix metadata & add more tests

* oops, wrong name

* still wrong name

* some more tracing to possibly help diagnose in the future

* ws fixes

Co-authored-by: AshesITR <[email protected]>

* another

Co-authored-by: AshesITR <[email protected]>

* use unset= to avoid %|||%

* remove unused rot()

* remove dead test

* rename

* document()

* move onload-only helper next to it, inside nocov

---------

Co-authored-by: AshesITR <[email protected]>

Author: MichaelChirico

.dev/lint_metadata_test.R

@@ -50,5 +50,7 @@ passed <- setdiff(
 )
 
 if (length(passed) > 0L) {
+  # Extra logging to possibly help debug
+  cat(sprintf("Executed the following test files: %s\n", toString(failed)))
   stop("Please add tests of lint metadata for the following linters: ", toString(passed))
 }

DESCRIPTION

@@ -23,7 +23,7 @@ BugReports: https://github.com/r-lib/lintr/issues
 Depends:
     R (>= 4.0)
 Imports:
-    backports (>= 1.4.0),
+    backports (>= 1.5.0),
     cli (>= 3.4.0),
     codetools,
     digest,
@@ -73,6 +73,7 @@ Collate:
     'brace_linter.R'
     'cache.R'
     'class_equals_linter.R'
+    'coalesce_linter.R'
     'commas_linter.R'
     'commented_code_linter.R'
     'comparison_negation_linter.R'

NAMESPACE

@@ -29,6 +29,7 @@ export(brace_linter)
 export(checkstyle_output)
 export(class_equals_linter)
 export(clear_cache)
+export(coalesce_linter)
 export(commas_linter)
 export(commented_code_linter)
 export(comparison_negation_linter)

NEWS.md

@@ -26,6 +26,10 @@
 * `object_name_linter()` and `object_length_linter()` apply to objects assigned with `assign()` or generics created with `setGeneric()` (#1665, @MichaelChirico).
 * `object_usage_linter()` gains argument `interpret_extensions` to govern which false positive-prone common syntaxes should be checked for used objects (#1472, @MichaelChirico). Currently `"glue"` (renamed from earlier argument `interpret_glue`) and `"rlang"` are supported. The latter newly covers usage of the `.env` pronoun like `.env$key`, where `key` was previously missed as being a used variable.
 
+### New linters
+
+* `coalesce_linter()` encourages the use of the infix operator `x %||% y`, which is equivalent to `if (is.null(x)) y else x` (#2246, @MichaelChirico). While this has long been used in many tidyverse packages (it was added to {ggplot2} in 2008), it became part of every R installation from R 4.4.0.
+
 ### Lint accuracy fixes: removing false positives
 
 * `unnecessary_nesting_linter()`:

R/coalesce_linter.R

@@ -0,0 +1,87 @@
+#' Encourage usage of the null coalescing operator `%||%`
+#'
+#' The `x %||% y` is equivalent to
+#'   `if (is.null(x)) y else x`, but more expressive.
+#'   It is exported by R since 4.4.0, and equivalents
+#'   have been available in other tidyverse packages
+#'   for much longer, e.g. 2008 for ggplot2.
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "if (is.null(x)) y else x",
+#'   linters = coalesce_linter()
+#' )
+#'
+#' lint(
+#'   text = "if (!is.null(x)) x else y",
+#'   linters = coalesce_linter()
+#' )
+#'
+#' lint(
+#'   text = "if (is.null(x[1])) x[2] else x[1]",
+#'   linters = coalesce_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "x %||% y",
+#'   linters = coalesce_linter()
+#' )
+#'
+#' lint(
+#'   text = "x %||% y",
+#'   linters = coalesce_linter()
+#' )
+#'
+#' lint(
+#'   text = "x[1] %||% x[2]",
+#'   linters = coalesce_linter()
+#' )
+#'
+#'
+#' @evalRd rd_tags("coalesce_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+coalesce_linter <- function() {
+  braced_expr_cond <- "expr[1][OP-LEFT-BRACE and count(*) = 3]/expr"
+  xpath <- glue("
+  parent::expr[
+    preceding-sibling::IF
+    and (
+      expr[2] = following-sibling::ELSE/following-sibling::expr
+      or expr[2] = following-sibling::ELSE/following-sibling::{braced_expr_cond}
+      or expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::ELSE/following-sibling::expr
+      or expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::ELSE/following-sibling::{braced_expr_cond}
+    )
+  ]
+    /parent::expr
+  |
+  parent::expr[
+    preceding-sibling::OP-EXCLAMATION
+    and parent::expr/preceding-sibling::IF
+    and (
+      expr[2] = parent::expr/following-sibling::expr[1]
+      or expr[2] = parent::expr/following-sibling::{braced_expr_cond}
+      or expr[2][LEFT_ASSIGN]/expr[1] = parent::expr/following-sibling::expr[1]
+      or expr[2][LEFT_ASSIGN]/expr[1] = parent::expr/following-sibling::{braced_expr_cond}
+    )
+  ]
+    /parent::expr
+    /parent::expr
+  ")
+
+  Linter(linter_level = "expression", function(source_expression) {
+    null_calls <- source_expression$xml_find_function_calls("is.null")
+    bad_expr <- xml_find_all(null_calls, xpath)
+    is_negation <- !is.na(xml_find_first(bad_expr, "expr/OP-EXCLAMATION"))
+    observed <- ifelse(is_negation, "if (!is.null(x)) x else y", "if (is.null(x)) y else x")
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = paste0("Use x %||% y instead of ", observed, "."),
+      type = "warning"
+    )
+  })
+}

R/get_source_expressions.R

@@ -67,11 +67,7 @@ get_source_expressions <- function(filename, lines = NULL) {
   old_lang <- set_lang("en")
   on.exit(reset_lang(old_lang))
 
-  source_expression$lines <- if (is.null(lines)) {
-    read_lines(filename)
-  } else {
-    lines
-  }
+  source_expression$lines <- lines %||% read_lines(filename)
 
   # Only regard explicit attribute terminal_newline=FALSE as FALSE and all other cases (e.g. NULL or TRUE) as TRUE.
   terminal_newline <- !isFALSE(attr(source_expression$lines, "terminal_newline", exact = TRUE))

R/methods.R

@@ -177,7 +177,7 @@ summary.lints <- function(object, ...) {
   tbl <- table(filenames, types)
   filenames <- rownames(tbl)
   res <- as.data.frame.matrix(tbl, row.names = NULL)
-  res$filenames <- filenames %||% character()
+  res$filenames <- filenames %|||% character()
   nms <- colnames(res)
   res[order(res$filenames), c("filenames", nms[nms != "filenames"])]
 }

R/object_usage_linter.R

@@ -81,7 +81,7 @@ object_usage_linter <- function(interpret_glue = NULL, interpret_extensions = c(
   Linter(linter_level = "file", function(source_expression) {
     pkg_name <- pkg_name(find_package(dirname(source_expression$filename)))
 
-    declared_globals <- try_silently(globalVariables(package = pkg_name %||% globalenv()))
+    declared_globals <- try_silently(globalVariables(package = pkg_name %|||% globalenv()))
 
     xml <- source_expression$full_xml_parsed_content
 

R/settings.R

@@ -269,7 +269,7 @@ validate_named_exclusion <- function(exclusions, idx) {
 lintr_option <- function(setting, default = NULL) getOption(paste0("lintr.", setting), default)
 
 get_setting <- function(setting, config, defaults) {
-  lintr_option(setting) %||% config[[setting]] %||% defaults[[setting]]
+  lintr_option(setting) %|||% config[[setting]] %|||% defaults[[setting]]
 }
 
 reset_settings <- function() list2env(default_settings, envir = settings)

R/trailing_blank_lines_linter.R

@@ -54,7 +54,7 @@ trailing_blank_lines_linter <- function() {
       lints[[length(lints) + 1L]] <- Lint(
         filename = source_expression$filename,
         line_number = length(source_expression$file_lines),
-        column_number = (nchar(last_line) %||% 0L) + 1L,
+        column_number = (nchar(last_line) %|||% 0L) + 1L,
         type = "style",
         message = "Add a terminal newline.",
         line = last_line

R/utils.R

@@ -1,4 +1,5 @@
-`%||%` <- function(x, y) {
+# TODO(#2768): possibly just use %||% instead
+`%|||%` <- function(x, y) {
   if (is.null(x) || length(x) == 0L || (is.atomic(x[[1L]]) && is.na(x[[1L]]))) {
     y
   } else {
@@ -83,7 +84,7 @@ auto_names <- function(x) {
 
 # The following functions is from dplyr
 names2 <- function(x) {
-  names(x) %||% rep("", length(x))
+  names(x) %|||% rep("", length(x))
 }
 
 get_content <- function(lines, info) {
@@ -103,14 +104,6 @@ get_content <- function(lines, info) {
   paste(lines, collapse = "\n")
 }
 
-logical_env <- function(x) {
-  res <- as.logical(Sys.getenv(x))
-  if (is.na(res)) {
-    return(NULL)
-  }
-  res
-}
-
 try_silently <- function(expr) {
   suppressWarnings(
     suppressMessages(

R/zzz.R

@@ -290,6 +290,14 @@ default_settings <- NULL
 settings <- new.env(parent = emptyenv())
 
 # nocov start
+logical_env <- function(x, unset = "") {
+  res <- as.logical(Sys.getenv(x, unset = unset))
+  if (is.na(res)) {
+    return(NULL)
+  }
+  res
+}
+
 .onLoad <- function(libname, pkgname) {
   op <- options()
   op_lintr <- list(
@@ -301,6 +309,9 @@ settings <- new.env(parent = emptyenv())
   # R>=4.1.0: ...names
   backports::import(pkgname, "...names")
 
+  # R>=4.4.0: %||%
+  backports::import(pkgname, "%||%")
+
   utils::assignInMyNamespace("default_settings", list(
     linters = default_linters,
     encoding = "UTF-8",
@@ -319,7 +330,7 @@ settings <- new.env(parent = emptyenv())
     exclude_linter_sep = rex(any_spaces, ",", any_spaces),
     exclusions = list(),
     cache_directory = R_user_dir("lintr", "cache"),
-    error_on_lint = logical_env("LINTR_ERROR_ON_LINT") %||% FALSE
+    error_on_lint = logical_env("LINTR_ERROR_ON_LINT", unset = FALSE)
   ))
 
   reset_settings()

inst/lintr/linters.csv

@@ -7,6 +7,7 @@ backport_linter,robustness configurable package_development
 boolean_arithmetic_linter,efficiency best_practices readability
 brace_linter,style readability default configurable
 class_equals_linter,best_practices robustness consistency
+coalesce_linter,readability consistency best_practices
 commas_linter,style readability default configurable
 commented_code_linter,style readability best_practices default
 comparison_negation_linter,readability consistency