Merge branch 'master' into ns-hooks-redux

.gitignore

@@ -5,3 +5,6 @@
 .idea
 bad.R
 script.R
+
+*.Rcheck
+lintr_*.tar.gz

NEWS.md

@@ -19,6 +19,7 @@
 * `object_name_linter()` now excludes special R hook functions such as `.onLoad` (#500, #614, @AshesITR and @michaelchirico)
 * `equals_na_linter()` now lints `x != NA` and `NA == x`, and skips usages in comments (#545, @michaelchirico)
 * Malformed Rmd files now cause a lint instead of an error (#571, #575, @AshesITR)
+* `object_name_linter()` gains a new default style, `"symbols"`, which won't lint all-symbol object names (in particular, that means operator names like `%+%` are skipped; #615, @michaelchirico)
 
 # lintr 2.0.1
 

R/actions.R

@@ -5,9 +5,12 @@ in_github_actions <- function() {
 # Output logging commands for any lints found
 github_actions_log_lints <- function(lints) {
   for (x in lints) {
-    cat(
-      sprintf("::warning file=%s,line=%s,col=%s::%s\n", x$filename, x$line_number, x$column_number, x$message),
-      sep = ""
+    file_line_col <- sprintf(
+      "file=%s,line=%s,col=%s", x$filename, x$line_number, x$column_number
     )
+    cat(sprintf(
+      "::warning %s::%s,%s\n",
+      file_line_col, file_line_col, x$message
+    ), sep = "")
   }
 }

R/declared_functions.R

@@ -1,22 +1,3 @@
-# Find all normal function declarations
-# TODO: setMethod() calls not included
-declared_functions <- function(x) {
-
-  xpath <- paste0(
-    # Top level expression which
-    "/exprlist/expr",
-
-    # Assigns to a symbol
-      "[./LEFT_ASSIGN|EQ_ASSIGN]",
-      "[./expr[FUNCTION]]",
-      "[./expr/SYMBOL]",
-
-    # Retrieve assigned name of the function
-    "/expr/SYMBOL/text()")
-
-  as.character(xml2::xml_find_all(x, xpath))
-}
-
 declared_s3_generics <- function(x) {
   xpath <- paste0(
     # Top level expression which

R/expect_lint.R

@@ -45,7 +45,7 @@ expect_lint <- function(content, checks, ..., file = NULL, language = "en") {
 
   if (is.null(file)) {
     file <- tempfile()
-    on.exit(unlink(file))
+    on.exit(unlink(file), add = TRUE)
     writeLines(content, con = file, sep = "\n")
   }
 

R/lint.R

@@ -28,7 +28,7 @@ lint <- function(filename, linters = NULL, cache = FALSE, ..., parse_settings =
   if (inline_data) {
     content <- gsub("\n$", "", filename)
     filename <- tempfile()
-    on.exit(unlink(filename))
+    on.exit(unlink(filename), add = TRUE)
     writeLines(text = content, con = filename, sep = "\n")
   }
 
@@ -378,11 +378,23 @@ rstudio_source_markers <- function(lints) {
   })
 
   # request source markers
-  rstudioapi::callFun("sourceMarkers",
-                      name = "lintr",
-                      markers = markers,
-                      basePath = package_path,
-                      autoSelect = "first")
+  out <- rstudioapi::callFun(
+    "sourceMarkers",
+    name = "lintr",
+    markers = markers,
+    basePath = package_path,
+    autoSelect = "first"
+  )
+
+  # workaround to avoid focusing an empty Markers pane
+  # when possible, better solution is to delete the "lintr" source marker list
+  # https://github.com/rstudio/rstudioapi/issues/209
+  if (length(lints) == 0) {
+    Sys.sleep(0.1)
+    rstudioapi::executeCommand("activateConsole")
+  }
+
+  out
 }
 
 #' Checkstyle Report for lint results

R/methods.R

@@ -52,9 +52,12 @@ markdown <- function(x, info, ...) {
 
 #' @export
 print.lints <- function(x, ...) {
+  rstudio_source_markers <- getOption("lintr.rstudio_source_markers", TRUE) &&
+    rstudioapi::hasFun("sourceMarkers")
+
   if (length(x)) {
-    if (getOption("lintr.rstudio_source_markers", TRUE) &&
-        rstudioapi::hasFun("sourceMarkers")) {
+    inline_data <- x[[1]][["filename"]] == "<text>"
+    if (!inline_data && rstudio_source_markers) {
       rstudio_source_markers(x)
     } else if (in_github_actions()) {
       github_actions_log_lints(x)
@@ -78,8 +81,7 @@ print.lints <- function(x, ...) {
     if (isTRUE(settings$error_on_lint)) {
       quit("no", 31, FALSE)
     }
-  } else if (getOption("lintr.rstudio_source_markers", TRUE) &&
-             rstudioapi::hasFun("sourceMarkers")) {
+  } else if (rstudio_source_markers) {
     # Empty lints: clear RStudio source markers
     rstudio_source_markers(x)
   }

R/object_name_linters.R

@@ -3,7 +3,7 @@
 #'   \Sexpr[stage=render, results=rd]{lintr:::regexes_rd}. A name should
 #'   match at least one of these styles.
 #' @export
-object_name_linter <- function(styles = "snake_case") {
+object_name_linter <- function(styles = c("snake_case", "symbols")) {
 
   .or_string <- function(xs) {
     # returns "<S> or <T>"
@@ -13,7 +13,7 @@ object_name_linter <- function(styles = "snake_case") {
     if (len <= 1) {
       return(xs)
     }
-    comma_sepd_prefix <- paste(xs[-len], collapse = ", ")
+    comma_sepd_prefix <- toString(xs[-len])
     paste(comma_sepd_prefix, "or", xs[len])
   }
 
@@ -24,10 +24,9 @@ object_name_linter <- function(styles = "snake_case") {
   )
 
   function(source_file) {
-    x <- global_xml_parsed_content(source_file)
-    if (is.null(x)) {
-      return()
-    }
+    if (is.null(source_file$full_xml_parsed_content)) return(list())
+
+    xml <- source_file$full_xml_parsed_content
 
     xpath <- paste0(
       # Left hand assignments
@@ -46,14 +45,14 @@ object_name_linter <- function(styles = "snake_case") {
       "//SYMBOL_FORMALS"
     )
 
-    assignments <- xml2::xml_find_all(x, xpath)
+    assignments <- xml2::xml_find_all(xml, xpath)
 
     # Retrieve assigned name
     nms <- strip_names(
       as.character(xml2::xml_find_first(assignments, "./text()")))
 
     generics <- strip_names(c(
-      declared_s3_generics(x),
+      declared_s3_generics(xml),
       namespace_imports()$fun,
       names(.knownS3Generics),
       .S3PrimitiveGenerics, ls(baseenv())))
@@ -105,7 +104,6 @@ strip_names <- function(x) {
   x
 }
 
-
 object_lint2 <- function(expr, source_file, message, type) {
   symbol <- xml2::as_list(expr)
   Lint(
@@ -281,53 +279,21 @@ object_lint <- function(source_file, token, message, type) {
 }
 
 
-object_name_linter_old <- function(style = "snake_case") {
-  make_object_linter(
-    function(source_file, token) {
-      name <- unquote(token[["text"]])
-      if (!any(matches_styles(name, style))) {
-        object_lint(
-          source_file,
-          token,
-          sprintf("Variable and function name style should be %s.", paste(style, collapse = " or ")),
-          "object_name_linter"
-        )
-      }
-    }
-  )
-}
-
-
 loweralnum <- rex(one_of(lower, digit))
 upperalnum <- rex(one_of(upper, digit))
 
 style_regexes <- list(
-  "CamelCase" = rex(start, maybe("."), upper, zero_or_more(alnum), end),
-  "camelCase" = rex(start, maybe("."), lower, zero_or_more(alnum), end),
-  "snake_case"     = rex(start, maybe("."), some_of(lower, digit), any_of("_", lower, digit), end),
-  "SNAKE_CASE"     = rex(start, maybe("."), some_of(upper, digit), any_of("_", upper, digit), end),
-  "dotted.case"    = rex(start, maybe("."), one_or_more(loweralnum), zero_or_more(dot, one_or_more(loweralnum)), end),
+  "symbols"     = rex(start, maybe("."), zero_or_more(none_of(alnum)), end),
+  "CamelCase"   = rex(start, maybe("."), upper, zero_or_more(alnum), end),
+  "camelCase"   = rex(start, maybe("."), lower, zero_or_more(alnum), end),
+  "snake_case"  = rex(start, maybe("."), some_of(lower, digit), any_of("_", lower, digit), end),
+  "SNAKE_CASE"  = rex(start, maybe("."), some_of(upper, digit), any_of("_", upper, digit), end),
+  "dotted.case" = rex(start, maybe("."), one_or_more(loweralnum), zero_or_more(dot, one_or_more(loweralnum)), end),
   "lowercase"   = rex(start, maybe("."), one_or_more(loweralnum), end),
   "UPPERCASE"   = rex(start, maybe("."), one_or_more(upperalnum), end)
 )
 
-regexes_rd <- paste0(collapse = ", ", paste0("\\sQuote{", names(style_regexes), "}"))
-
-matches_styles <- function(name, styles=names(style_regexes)) {
-  invalids <- paste(styles[!styles %in% names(style_regexes)], collapse=", ")
-  if (nzchar(invalids)) {
-    valids <- paste(names(style_regexes), collapse=", ")
-    stop(sprintf("Invalid style(s) requested: %s\nValid styles are: %s\n", invalids, valids))
-  }
-  name <- re_substitutes(name, rex(start, one_or_more(dot)), "")  # remove leading dots
-  vapply(
-    style_regexes[styles],
-    re_matches,
-    logical(1L),
-    data=name
-  )
-}
-
+regexes_rd <- toString(paste0("\\sQuote{", names(style_regexes), "}"))
 
 #' @describeIn linters check that object names are not too long.
 #' @export

R/tree-utils.R

@@ -73,18 +73,6 @@ parents <- function(data, id, levels = Inf, simplify = TRUE) {
   }
 }
 
-family <- function(data, id, parent_levels = 1L, child_levels = Inf) {
-  parents <- parents(data, id, parent_levels)
-  c(parents,
-    unlist(lapply(
-        parents,
-        children,
-        data = data,
-        levels = child_levels)
-      )
-    )
-}
-
 siblings <- function(data, id, child_levels = Inf) {
   parents <- parents(data, id, 1L)
   res <- unlist(lapply(

R/utils.R

@@ -74,16 +74,6 @@ auto_names <- function(x) {
   nms
 }
 
-blank_text <- function(s, re, shift_start = 0, shift_end = 0) {
-  m <- gregexpr(re, s, perl = TRUE)
-  regmatches(s, m) <- lapply(regmatches(s, m),
-    quoted_blanks,
-    shift_start = shift_start,
-    shift_end = shift_end)
-
-  s
-}
-
 quoted_blanks <- function(matches, shift_start = 0, shift_end = 0) {
   lengths <- nchar(matches)
   blanks <- vapply(Map(rep.int,
@@ -101,15 +91,6 @@ names2 <- function(x) {
   names(x) %||% rep("", length(x))
 }
 
-recursive_ls <- function(env) {
-  if (parent.env(env) %!=% emptyenv()) {
-    c(ls(envir = env), recursive_ls(parent.env(env)))
-  }
-  else {
-    ls(envir = env)
-  }
-}
-
 safe_parse_to_xml <- function(parsed_content) {
   if (is.null(parsed_content)) return(NULL)
   tryCatch(xml2::read_xml(xmlparsedata::xml_parse_data(parsed_content)), error = function(e) NULL)
@@ -172,7 +153,6 @@ try_silently <- function(expr) {
 }
 
 viapply <- function(x, ...) vapply(x, ..., FUN.VALUE = integer(1))
-vcapply <- function(x, ...) vapply(x, ..., FUN.VALUE = character(1))
 
 # imitate sQuote(x, q) [requires R>=3.6]
 quote_wrap <- function(x, q) paste0(q, x, q)

R/zzz.R

@@ -1,11 +1,3 @@
-named_list <- function(...) {
-  nms <- re_substitutes(as.character(eval(substitute(alist(...)))),
-    rex("(", anything), "")
-  vals <- list(...)
-  names(vals) <- nms
-  vals[!vapply(vals, is.null, logical(1))]
-}
-
 #' Modify lintr defaults
 #'
 #' Make a new list based on \pkg{lintr}'s default linters, undesirable
@@ -45,24 +37,26 @@ named_list <- function(...) {
 with_defaults <- function(..., default = default_linters) {
   vals <- list(...)
   nms <- names2(vals)
-  missing <- nms == ""
+  missing <- !nzchar(nms, keepNA = TRUE)
   if (any(missing)) {
     args <- as.character(eval(substitute(alist(...)[missing])))
     # foo_linter(x=1) => "foo"
     # var[["foo"]]    => "foo"
     nms[missing] <- re_substitutes(
       re_substitutes(
         re_substitutes(args, rex("(", anything), ""),
-        rex(start, anything, "[\""),
-        ""),
-      rex("\"]", anything, end),
-      "")
+        rex(start, anything, '["'),
+        ""
+      ),
+      rex('"]', anything, end),
+      ""
+    )
   }
 
-  vals[nms == vals] <- NA
+  is.na(vals) <- nms == vals
   default[nms] <- vals
 
-  res <- default[!vapply(default, is.null, logical(1))]
+  res <- default[!vapply(default, is.null, logical(1L))]
 
   res[] <- lapply(res, function(x) {
     prev_class <- class(x)
@@ -73,11 +67,6 @@ with_defaults <- function(..., default = default_linters) {
   })
 }
 
-# this is just to make the auto documentation cleaner
-str.lintr_function <- function(x, ...) {
-  cat("\n")
-}
-
 #' Default linters
 #'
 #' List of default linters for \code{\link{lint}}. Use \code{\link{with_defaults}} to customize it.
@@ -182,6 +171,7 @@ default_settings <- NULL
 
 settings <- NULL
 
+# nocov start
 .onLoad <- function(libname, pkgname) {
   op <- options()
   op.lintr <- list(
@@ -211,3 +201,4 @@ settings <- NULL
   settings <<- list2env(default_settings, parent = emptyenv())
   invisible()
 }
+# nocov end

tests/testthat/dummy_packages/clean/DESCRIPTION

@@ -0,0 +1,2 @@
+Package: clean
+Version: 0.0.1

tests/testthat/dummy_packages/clean/R/default_linter_testcode.R

@@ -0,0 +1,3 @@
+f <- function(x, y = 1) x + y
+message("hello")
+y <- 2 + (1:10)