Skip to content

Commit 8340014

Browse files
AshesITRAshesITR
committed
Refactor object_length_linter to properly handle generics
Fixes #871
1 parent 209e32c commit 8340014

File tree

3 files changed

+105
-198
lines changed

3 files changed

+105
-198
lines changed

‎NEWS.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,8 @@ function calls. (#850, #851, @renkun-ken)
9797
* `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)
9898
* `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)
9999
* `infix_spaces_linter()` now throws a lint on `a~b` and `function(a=1) {}` (#930, @michaelchirico)
100+
* `object_length_linter()` correctly detects generics and only counts the implementation class towards the length.
101+
(#871, @AshesITR)
100102

101103
# lintr 2.0.1
102104

‎R/object_name_linters.R

Lines changed: 73 additions & 190 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,40 @@
1+
object_name_xpath <- paste0(
2+
# assignments
3+
"//SYMBOL[",
4+
" not(preceding-sibling::OP-DOLLAR)",
5+
" and ancestor::expr[",
6+
" following-sibling::LEFT_ASSIGN",
7+
" or preceding-sibling::RIGHT_ASSIGN",
8+
" or following-sibling::EQ_ASSIGN",
9+
" ]",
10+
" and not(ancestor::expr[",
11+
" preceding-sibling::OP-LEFT-BRACKET",
12+
" or preceding-sibling::LBB",
13+
" ])",
14+
"]",
15+
16+
" | ",
17+
18+
"//STR_CONST[",
19+
" not(preceding-sibling::OP-DOLLAR)",
20+
" and ancestor::expr[",
21+
" following-sibling::LEFT_ASSIGN",
22+
" or preceding-sibling::RIGHT_ASSIGN",
23+
" or following-sibling::EQ_ASSIGN",
24+
" ]",
25+
" and not(ancestor::expr[",
26+
" preceding-sibling::OP-LEFT-BRACKET",
27+
" or preceding-sibling::LBB",
28+
" ])",
29+
"]",
30+
31+
# Or
32+
" | ",
33+
34+
# Formal argument names
35+
"//SYMBOL_FORMALS"
36+
)
37+
138
#' Object name linter
239
#'
340
#' Check that object names conform to a naming style.
@@ -34,44 +71,7 @@ object_name_linter <- function(styles = c("snake_case", "symbols")) {
3471

3572
xml <- source_file$full_xml_parsed_content
3673

37-
xpath <- paste0(
38-
# assignments
39-
"//SYMBOL[",
40-
" not(preceding-sibling::OP-DOLLAR)",
41-
" and ancestor::expr[",
42-
" following-sibling::LEFT_ASSIGN",
43-
" or preceding-sibling::RIGHT_ASSIGN",
44-
" or following-sibling::EQ_ASSIGN",
45-
" ]",
46-
" and not(ancestor::expr[",
47-
" preceding-sibling::OP-LEFT-BRACKET",
48-
" or preceding-sibling::LBB",
49-
" ])",
50-
"]",
51-
52-
" | ",
53-
54-
"//STR_CONST[",
55-
" not(preceding-sibling::OP-DOLLAR)",
56-
" and ancestor::expr[",
57-
" following-sibling::LEFT_ASSIGN",
58-
" or preceding-sibling::RIGHT_ASSIGN",
59-
" or following-sibling::EQ_ASSIGN",
60-
" ]",
61-
" and not(ancestor::expr[",
62-
" preceding-sibling::OP-LEFT-BRACKET",
63-
" or preceding-sibling::LBB",
64-
" ])",
65-
"]",
66-
67-
# Or
68-
" | ",
69-
70-
# Formal argument names
71-
"//SYMBOL_FORMALS"
72-
)
73-
74-
assignments <- xml2::xml_find_all(xml, xpath)
74+
assignments <- xml2::xml_find_all(xml, object_name_xpath)
7575

7676
# Retrieve assigned name
7777
nms <- strip_names(
@@ -93,7 +93,7 @@ object_name_linter <- function(styles = c("snake_case", "symbols")) {
9393

9494
lapply(
9595
assignments[!matches_a_style],
96-
object_lint2,
96+
object_lint,
9797
source_file,
9898
lint_msg
9999
)
@@ -131,7 +131,7 @@ strip_names <- function(x) {
131131
x
132132
}
133133

134-
object_lint2 <- function(expr, source_file, message) {
134+
object_lint <- function(expr, source_file, message) {
135135
symbol <- xml2::as_list(expr)
136136
Lint(
137137
filename = source_file$filename,
@@ -144,135 +144,6 @@ object_lint2 <- function(expr, source_file, message) {
144144
)
145145
}
146146

147-
object_linter_factory <- function(fun, name = linter_auto_name()) {
148-
force(name)
149-
Linter(function(source_file) {
150-
151-
token_nums <- ids_with_token(
152-
source_file, rex(start, "SYMBOL" %if_next_isnt% "_SUB"), fun = re_matches
153-
)
154-
if (length(token_nums) == 0) {
155-
return(list())
156-
}
157-
tokens <- with_id(source_file, token_nums)
158-
names <- unquote(tokens[["text"]]) # remove surrounding backticks
159-
160-
keep_indices <- which(
161-
!is_operator(names) &
162-
!is_known_generic(names) &
163-
!is_base_function(names)
164-
)
165-
166-
lapply(
167-
keep_indices,
168-
function(i) {
169-
token <- tokens[i, ]
170-
if (is_declared_here(token, source_file) &&
171-
!is_external_reference(source_file, token[["id"]])) {
172-
fun(source_file, token)
173-
}
174-
}
175-
)
176-
}, name = name)
177-
}
178-
179-
known_generic_regex <- rex(
180-
start,
181-
or(
182-
unique(
183-
# Clean up "as.data.frame" to "as", "names<-" to "names", etc
184-
re_substitutes(c(names(.knownS3Generics), .S3PrimitiveGenerics),
185-
rex(or(dot, "<-"), anything, end), "")
186-
)
187-
),
188-
dot
189-
)
190-
191-
is_known_generic <- function(name) {
192-
re_matches(name, known_generic_regex)
193-
}
194-
195-
is_declared_here <- function(token, source_file) {
196-
# The object was declared here if one of the following is true:
197-
# * its name precedes a left assign ("<-" or "<<-") or equal assign ("=")
198-
# * its name follows a right assign ("->" or "->>")
199-
# * its name is not "..." and its first sibling token is a function definition
200-
filt <- filter_out_token_type(source_file[["parsed_content"]], "expr")
201-
assign_regex <- rex(start, or("EQ_ASSIGN", "LEFT_ASSIGN"), end)
202-
l <- which(filt[, "id"] == token[["id"]])
203-
if ((l + 1L <= dim(filt)[[1L]] && re_matches(filt[l + 1L, "token"], assign_regex)) ||
204-
(l >= 2L && filt[l - 1L, "token"] == "RIGHT_ASSIGN")) {
205-
# assigned variable or function parameter
206-
TRUE
207-
} else {
208-
sibling_ids <- siblings(source_file[["parsed_content"]], token[["id"]], 1L)
209-
if (token[["text"]] != "..." &&
210-
length(sibling_ids) &&
211-
with_id(source_file, sibling_ids[[1L]])[["text"]] == "function") {
212-
# parameter in function definition
213-
TRUE
214-
} else {
215-
FALSE
216-
}
217-
}
218-
}
219-
220-
is_operator <- function(name) {
221-
name != make.names(name)
222-
}
223-
224-
is_external_reference <- function(source_file, id) {
225-
sibling_tokens <- with_id(source_file, siblings(source_file$parsed_content, id, 1))$token
226-
any(sibling_tokens %in% c("NS_GET", "NS_GET_INT"))
227-
}
228-
229-
# via unlist(tools:::.get_standard_package_names(), use.names = FALSE)
230-
base_pkgs <- c(
231-
"base",
232-
"tools",
233-
"utils",
234-
"grDevices",
235-
"graphics",
236-
"stats",
237-
"datasets",
238-
"methods",
239-
"grid",
240-
"splines",
241-
"stats4",
242-
"compiler",
243-
"parallel",
244-
"MASS",
245-
"lattice",
246-
"Matrix",
247-
"nlme",
248-
"survival",
249-
"boot",
250-
"cluster",
251-
"codetools",
252-
"foreign",
253-
"KernSmooth",
254-
"rpart",
255-
"class",
256-
"nnet",
257-
"spatial",
258-
"mgcv"
259-
)
260-
261-
# some duplicates such as .onLoad appear in multiple packages; sort for efficiency
262-
base_funs <- sort(unique(unlist(lapply(
263-
base_pkgs,
264-
function(x) {
265-
name <- try_silently(getNamespace(x))
266-
if (!inherits(name, "try-error")) {
267-
ls(name, all.names = TRUE)
268-
}
269-
}
270-
))))
271-
272-
is_base_function <- function(x) {
273-
x %in% base_funs
274-
}
275-
276147
# see ?".onLoad", ?Startup, and ?quit. Remove leading dot to match behavior of strip_names().
277148
# All of .onLoad, .onAttach, and .onUnload are used in base packages,
278149
# and should be caught in is_base_function; they're included here for completeness / stability
@@ -292,19 +163,6 @@ is_special_function <- function(x) {
292163
x %in% special_funs
293164
}
294165

295-
object_lint <- function(source_file, token, message) {
296-
Lint(
297-
filename = source_file$filename,
298-
line_number = token$line1,
299-
column_number = token$col1,
300-
type = "style",
301-
message = message,
302-
line = source_file$lines[as.character(token$line1)],
303-
ranges = list(c(token$col1, token$col2))
304-
)
305-
}
306-
307-
308166
loweralnum <- rex(one_of(lower, digit))
309167
upperalnum <- rex(one_of(upper, digit))
310168

@@ -330,13 +188,38 @@ regexes_rd <- toString(paste0("\\sQuote{", names(style_regexes), "}"))
330188
#' @seealso [linters] for a complete list of linters available in lintr.
331189
#' @export
332190
object_length_linter <- function(length = 30L) {
333-
object_linter_factory(function(source_file, token) {
334-
if (nchar(token$text) > length) {
335-
object_lint(
336-
source_file,
337-
token,
338-
paste0("Variable and function names should not be longer than ", length, " characters.")
339-
)
340-
}
191+
lint_msg <- paste0("Variable and function names should not be longer than ", length, " characters.")
192+
193+
Linter(function(source_file) {
194+
if (is.null(source_file$full_xml_parsed_content)) return(list())
195+
196+
xml <- source_file$full_xml_parsed_content
197+
198+
assignments <- xml2::xml_find_all(xml, object_name_xpath)
199+
200+
# Retrieve assigned name
201+
nms <- strip_names(
202+
xml2::xml_text(assignments)
203+
)
204+
205+
generics <- strip_names(c(
206+
declared_s3_generics(xml),
207+
imported_s3_generics(namespace_imports(find_package(source_file$filename)))$fun,
208+
.base_s3_generics
209+
))
210+
generics <- unique(generics[nzchar(generics)])
211+
212+
# Remove generic function names from generic implementations
213+
# This only lints S3 implementations if the class names are too long, still lints generics if they are too long.
214+
nms_stripped <- re_substitutes(nms, rex(start, or(generics), "."), "")
215+
216+
too_long <- nchar(nms_stripped) > length
217+
218+
lapply(
219+
assignments[too_long],
220+
object_lint,
221+
source_file,
222+
lint_msg
223+
)
341224
})
342225
}

‎tests/testthat/test-object_length_linter.R

Lines changed: 30 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,37 @@
11
test_that("returns the correct linting", {
22

3-
expect_lint("blah",
4-
NULL,
5-
object_length_linter())
3+
linter <- object_length_linter()
4+
lint_msg <- rex("Variable and function names should not be longer than 30 characters.")
65

7-
expect_lint("very_very_very_very_long_variable_names_are_not_ideal <- 1",
8-
rex("Variable and function names should not be longer than 30 characters."),
9-
object_length_linter())
6+
expect_lint("blah", NULL, linter)
107

11-
expect_lint("very_very_very_very_long_variable_names_are_not_ideal <<- 'foo'",
8+
expect_lint("very_very_very_very_long_variable_names_are_not_ideal <- 1", lint_msg, linter)
9+
10+
expect_lint(
11+
"very_very_very_very_long_variable_names_are_not_ideal <<- 'foo'",
1212
rex("Variable and function names should not be longer than 40 characters."),
13-
object_length_linter(length = 40))
13+
object_length_linter(length = 40)
14+
)
15+
16+
# Regression tests for #871
17+
18+
expect_lint("print.very_very_long_class_name <- 1", NULL, linter)
19+
expect_lint("print.very_very_very_very_long_class_name <- 1", lint_msg, linter)
20+
21+
expect_lint(trim_some("
22+
very_very_very_long_generic_name <- function(x, ...) {
23+
UseMethod(\"very_very_very_long_generic_name\")
24+
}
25+
26+
very_very_very_long_generic_name.short_class <- function(x, ...) {
27+
42L
28+
}
1429
30+
very_very_very_long_generic_name.very_very_very_very_long_class_name <- function(x, ...) {
31+
2L
32+
}
33+
"), list(
34+
list(line_number = 1),
35+
list(line_number = 9)
36+
), linter)
1537
})

0 commit comments

Comments
 (0)