Skip to content

Commit f8bb91e

Browse files
MichaelChiricoMichaelChirico
authored
Support for piping into sprintf() in sprintf_linter() (#2049)
* WIP * comment for clarity * explicit integer * duplicate helper no longer needed * catch an edge case, add tests * add no-error test * new tests with nesting, all pipes * delint * skip on old versions
1 parent 0a961fb commit f8bb91e

File tree

4 files changed

+105
-89
lines changed

4 files changed

+105
-89
lines changed

‎NEWS.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@
2222
+ `undesirable_function_linter()`
2323
+ `unreachable_code_linter()`
2424
+ `yoda_test_linter()`
25+
* `sprintf_linter()` is pipe-aware, so that `x %>% sprintf(fmt = "%s")` no longer lints (#1943, @MichaelChirico).
2526

2627
### New linters
2728

‎R/sprintf_linter.R

Lines changed: 67 additions & 56 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,7 @@
2727
#' @seealso [linters] for a complete list of linters available in lintr.
2828
#' @export
2929
sprintf_linter <- function() {
30-
xpath <- "
30+
call_xpath <- "
3131
//SYMBOL_FUNCTION_CALL[text() = 'sprintf' or text() = 'gettextf']
3232
/parent::expr
3333
/parent::expr[
@@ -39,14 +39,79 @@ sprintf_linter <- function() {
3939
]
4040
"
4141

42+
pipes <- setdiff(magrittr_pipes, "%$%")
43+
in_pipe_xpath <- glue("self::expr[
44+
preceding-sibling::*[1][self::PIPE or self::SPECIAL[{ xp_text_in_table(pipes) }]]
45+
and (
46+
preceding-sibling::*[2]/STR_CONST
47+
or SYMBOL_SUB[text() = 'fmt']/following-sibling::expr[1]/STR_CONST
48+
)
49+
]")
50+
51+
is_missing <- function(x) is.symbol(x) && !nzchar(x)
52+
53+
#' Zap sprintf() call to contain only constants
54+
#'
55+
#' Set all extra arguments to 0L if they aren't a constant
56+
#'
57+
#' @param parsed_expr A parsed `sprintf()` call
58+
#'
59+
#' @return A `sprintf()` call with all non-constants replaced by `0L`
60+
#' (which is compatible with all sprintf format specifiers)
61+
zap_extra_args <- function(parsed_expr) {
62+
if ("fmt" %in% names(parsed_expr)) {
63+
fmt_loc <- which(names(parsed_expr) == "fmt")
64+
} else {
65+
fmt_loc <- 2L
66+
}
67+
68+
if (length(parsed_expr) >= 3L) {
69+
for (i in setdiff(seq_along(parsed_expr), c(1L, fmt_loc))) {
70+
if (!is_missing(parsed_expr[[i]]) && !is.atomic(parsed_expr[[i]])) {
71+
parsed_expr[[i]] <- 0L
72+
}
73+
}
74+
}
75+
parsed_expr
76+
}
77+
78+
# Anticipate warnings of a sprintf() call
79+
#
80+
# Try running a static sprintf() call to determine whether it will produce warnings or errors due to format
81+
# misspecification
82+
#
83+
# @param xml An XML node representing a `sprintf()` call (i.e. the `<expr>` node containing the call)
84+
#
85+
# @return A string, either `NA_character_` or the text of generated errors and warnings from the `sprintf()` call when
86+
# replacing all dynamic components by 0, which is compatible with all format specifiers.
87+
capture_sprintf_warning <- function(xml) {
88+
parsed_expr <- xml2lang(xml)
89+
# convert x %>% sprintf(...) to sprintf(x, ...)
90+
if (length(xml_find_first(xml, in_pipe_xpath)) > 0L) {
91+
arg_names <- names(parsed_expr)
92+
arg_idx <- 2L:length(parsed_expr)
93+
parsed_expr[arg_idx + 1L] <- parsed_expr[arg_idx]
94+
names(parsed_expr)[arg_idx + 1L] <- arg_names[arg_idx]
95+
parsed_expr[[2L]] <- xml2lang(xml_find_first(xml, "preceding-sibling::*[2]"))
96+
names(parsed_expr)[2L] <- ""
97+
}
98+
parsed_expr <- zap_extra_args(parsed_expr)
99+
res <- tryCatch(eval(parsed_expr, envir = baseenv()), warning = identity, error = identity)
100+
if (inherits(res, "condition")) {
101+
conditionMessage(res)
102+
} else {
103+
NA_character_
104+
}
105+
}
106+
42107
Linter(function(source_expression) {
43108
if (!is_lint_level(source_expression, "file")) {
44109
return(list())
45110
}
46111

47112
xml <- source_expression$full_xml_parsed_content
48113

49-
sprintf_calls <- xml_find_all(xml, xpath)
114+
sprintf_calls <- xml_find_all(xml, call_xpath)
50115

51116
message <- vapply(sprintf_calls, capture_sprintf_warning, character(1L))
52117

@@ -59,57 +124,3 @@ sprintf_linter <- function() {
59124
)
60125
})
61126
}
62-
63-
#' Zap sprintf() call to contain only constants
64-
#'
65-
#' Set all extra arguments to 0L if they aren't a constant
66-
#'
67-
#' @param parsed_expr A parsed `sprintf()` call
68-
#'
69-
#' @return A `sprintf()` call with all non-constants replaced by `0L`
70-
#' (which is compatible with all sprintf format specifiers)
71-
#'
72-
#' @noRd
73-
zap_extra_args <- function(parsed_expr) {
74-
is_missing <- function(x) {
75-
is.symbol(x) && !nzchar(x)
76-
}
77-
78-
if ("fmt" %in% names(parsed_expr)) {
79-
fmt_loc <- which(names(parsed_expr) == "fmt")
80-
} else {
81-
fmt_loc <- 2L
82-
}
83-
84-
if (length(parsed_expr) >= 3L) {
85-
for (i in setdiff(seq_along(parsed_expr), c(1L, fmt_loc))) {
86-
if (!is_missing(parsed_expr[[i]]) && !is.atomic(parsed_expr[[i]])) {
87-
parsed_expr[[i]] <- 0L
88-
}
89-
}
90-
}
91-
parsed_expr
92-
}
93-
94-
#' Anticipate warnings of a sprintf() call
95-
#'
96-
#' Try running a static sprintf() call to determine whether it will produce warnings or errors due to format
97-
#' misspecification
98-
#'
99-
#' @param xml An XML node representing a `sprintf()` call (i.e. the `<expr>` node containing the call)
100-
#'
101-
#' @return A string, either `NA_character_` or the text of generated errors and warnings from the `sprintf()` call when
102-
#' replacing all dynamic components by 0, which is compatible with all format specifiers.
103-
#'
104-
#' @noRd
105-
capture_sprintf_warning <- function(xml) {
106-
text <- get_r_code(xml)
107-
parsed_expr <- try_silently(parse(text = text, keep.source = FALSE)[[1L]])
108-
parsed_expr <- zap_extra_args(parsed_expr)
109-
res <- tryCatch(eval(parsed_expr, envir = baseenv()), warning = identity, error = identity)
110-
if (inherits(res, "condition")) {
111-
conditionMessage(res)
112-
} else {
113-
NA_character_
114-
}
115-
}

‎R/utils.R

Lines changed: 0 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -244,39 +244,6 @@ get_r_string <- function(s, xpath = NULL) {
244244
out
245245
}
246246

247-
#' Convert XML node to R code within
248-
#'
249-
#' NB this is not equivalent to `xml_text(xml)` in the presence of line breaks
250-
#'
251-
#' @param xml An `xml_node`.
252-
#'
253-
#' @return A source-code equivalent of `xml` with unnecessary whitespace removed.
254-
#'
255-
#' @noRd
256-
get_r_code <- function(xml) {
257-
# shortcut if xml has line1 and line2 attrs and they are equal
258-
# if they are missing, xml_attr() returns NA, so we continue
259-
if (isTRUE(xml_attr(xml, "line1") == xml_attr(xml, "line2"))) {
260-
return(xml_text(xml))
261-
}
262-
# find all unique line numbers
263-
line_numbers <- sort(unique(xml_find_num(
264-
xml_find_all(xml, "./descendant-or-self::*[@line1]"),
265-
"number(./@line1)"
266-
)))
267-
if (length(line_numbers) <= 1L) {
268-
# no line breaks necessary
269-
return(xml_text(xml))
270-
}
271-
lines <- vapply(line_numbers, function(line_num) {
272-
# all terminal nodes starting on line_num
273-
paste(xml_text(
274-
xml_find_all(xml, sprintf("./descendant-or-self::*[@line1 = %d and not(*)]", line_num))
275-
), collapse = "")
276-
}, character(1L))
277-
paste(lines, collapse = "\n")
278-
}
279-
280247
#' str2lang, but for xml children.
281248
#'
282249
#' [xml2::xml_text()] is deceptively close to obviating this helper, but it collapses

‎tests/testthat/test-sprintf_linter.R

Lines changed: 37 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -91,3 +91,40 @@ test_that("edge cases are detected correctly", {
9191
linter
9292
)
9393
})
94+
95+
local({
96+
linter <- sprintf_linter()
97+
unused_fmt_msg <- "too few arguments"
98+
unused_arg_msg <- "one argument not used by format"
99+
pipes <- pipes(exclude = "%$%")
100+
patrick::with_parameters_test_that(
101+
"piping into sprintf works",
102+
{
103+
expect_lint(paste("x", pipe, "sprintf(fmt = '%s')"), NULL, linter)
104+
# no fmt= specified -> this is just 'sprintf("%s", "%s%s")', which won't lint
105+
expect_lint(paste('"%s"', pipe, 'sprintf("%s%s")'), NULL, linter)
106+
expect_lint(paste("x", pipe, "sprintf(fmt = '%s%s')"), unused_fmt_msg, linter)
107+
108+
# Cannot evaluate statically --> skip
109+
expect_lint(paste("x", pipe, 'sprintf("a")'), NULL, linter)
110+
# Nested pipes
111+
expect_lint(
112+
paste("'%%sb'", pipe, "sprintf('%s')", pipe, "sprintf('a')"),
113+
if (getRversion() >= "4.1.0") list(column_number = nchar(paste("'%%sb'", pipe, "x")), message = unused_arg_msg),
114+
linter
115+
)
116+
expect_lint(
117+
paste("x", pipe, 'sprintf(fmt = "%s")', pipe, 'sprintf(fmt = "%s%s")'),
118+
list(column_number = nchar(paste("x", pipe, 'sprintf(fmt = "%s")', pipe, "x")), message = unused_fmt_msg),
119+
linter
120+
)
121+
expect_lint(
122+
paste("x", pipe, 'sprintf(fmt = "%s%s")', pipe, 'sprintf(fmt = "%s")'),
123+
list(column_number = nchar(paste("x", pipe, "x")), message = unused_fmt_msg),
124+
linter
125+
)
126+
},
127+
pipe = pipes,
128+
.test_name = names(pipes)
129+
)
130+
})

0 commit comments

Comments
 (0)