Linter to check that the `fmt` argument of `sprintf()` comes last

sprintf_fmt_bottom_linter.R

sprintf_fmt_bottom_linter <- function() {
  xpath <- "
  //SYMBOL_FUNCTION_CALL[text() = 'sprintf']
    /parent::expr/following-sibling::expr[last()]
    /preceding-sibling::*[2][not(
      self::SYMBOL_SUB[text() = 'f' or text() = 'fm' or text() = 'fmt']
    )]
    /preceding-sibling::expr[
      preceding-sibling::*[2][
        self::SYMBOL_SUB[text() = 'f' or text() = 'fm' or text() = 'fmt']
      ]
      or
      preceding-sibling::*[not(
        self::SYMBOL_SUB[text() = 'f' or text() = 'fm' or text() = 'fmt']
      )]
    ][last()]
  "
  
  lintr::Linter(function(source_expression) {
    if (!lintr::is_lint_level(source_expression, "expression")) {
      return(list())
    }
    
    xml <- source_expression$xml_parsed_content
    
    bad_expr <- xml2::xml_find_all(xml, xpath)
        
    lintr::xml_nodes_to_lints(
      bad_expr,
      source_expression = source_expression,
      lint_message = "Consider putting the `fmt` argument last for readability",
      type = "style"
    )
  })
  
}

name <- "June Choe"
github_name <- "yjunechoe"

# Preferred
sprintf(
  name,
  github_name,
  fmt = "My name is %1$s and you'll find me on GitHub as %2$s!"
)
#> [1] "My name is June Choe and you'll find me on GitHub as yjunechoe!"

# BAD: `fmt` is first (unnamed)
lintr::lint(
  text = r"(
    sprintf(
      "My name is %1$s and you'll find me on GitHub as %2$s!",
      name,
      github_name
    )
  )",
  linters = sprintf_fmt_bottom_linter()
)
#> <text>:3:7: style: [sprintf_fmt_bottom_linter] Consider putting the `fmt` argument last for readability
#>       "My name is %1$s and you'll find me on GitHub as %2$s!",
#>       ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# BAD: `fmt` is first (named)
lintr::lint(
  text = r"(
    sprintf(
      fmt = "My name is %1$s and you'll find me on GitHub as %2$s!",
      name,
      github_name
    )
  )",
  linters = sprintf_fmt_bottom_linter()
)
#> <text>:3:13: style: [sprintf_fmt_bottom_linter] Consider putting the `fmt` argument last for readability
#>       fmt = "My name is %1$s and you'll find me on GitHub as %2$s!",
#>             ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# GOOD: `fmt` named and last
lintr::lint(
  text = r"(
    sprintf(
      name,
      github_name,
      fmt = "My name is %1$s and you'll find me on GitHub as %2$s!",
    )
  )",
  linters = sprintf_fmt_bottom_linter()
)

Addin:

sprintf_fmt_bottom_transform <- function(x) {
  sprintf_args <- as.list(parse(text = x)[[1]])[-1]
  if (!is.null(names(sprintf_args))) {
    fmt_arg <- which.max(pmatch(names(sprintf_args), "fmt"))
  } else {
    fmt_arg <- 1
  }
  pos_arg <- sprintf_args[-fmt_arg]
  fmt_str <- sprintf_args[[fmt_arg]]
  matches <- regmatches(fmt_str, gregexpr("%.*?[aAdifeEgGosxX%]", fmt_str))[[1]]
  matches_stripped <- gsub("%(\\d+\\$)?", "", matches)
  matches_positioned <- paste0("%", seq_along(pos_arg), "$", matches_stripped)
  fmt_template <- strsplit(fmt_str, "%.*?[aAdifeEgGosxX%]")[[1]]
  offset <- length(fmt_template) - length(matches_positioned)
  fmt_new <- paste(t(cbind(fmt_template, c(matches_positioned, rep("", offset)))), collapse = "")
  sprintf_args <- c(setNames(pos_arg, matches_positioned), list(fmt = fmt_new))
  sprintf_new_expr <- as.call(c(list(quote(sprintf)), sprintf_args))
  sprintf_new_expr
}

addin_fmt_bottom_transform <- function() {
  context <- rstudioapi::getActiveDocumentContext()
  sel <- context$selection[[1]]$range
  txt <- context$selection[[1]]$text
  tryCatch(
    {
      expr <- sprintf_fmt_bottom_transform(txt)
      # styling
      new <- deparse(expr)
      new <- gsub("\\(", "\\(\n  ", new)
      new <- gsub("\\)", "\n\\)", new)
      new <- gsub(",", ",\n ", new)
      new <- gsub("`", '"', new)
      rstudioapi::modifyRange(sel, new)
    },
    error = function(...) NULL
  )
}