R/backport_linter.R

In jimhester/lintr: A 'Linter' for R Code

#' Backport linter
#'
#' Check for usage of unavailable functions. Not reliable for testing r-devel dependencies.
#'
#' @param r_version Minimum R version to test for compatibility
#' @param except Character vector of functions to be excluded from linting.
#'  Use this to list explicitly defined backports, e.g. those imported from the `{backports}` package or manually
#'  defined in your package.
#'
#' @examples
#' # will produce lints
#' lint(
#'   text = "trimws(x)",
#'   linters = backport_linter("3.0.0")
#' )
#'
#' lint(
#'   text = "str2lang(x)",
#'   linters = backport_linter("3.2.0")
#' )
#'
#' # okay
#' lint(
#'   text = "trimws(x)",
#'   linters = backport_linter("3.6.0")
#' )
#'
#' lint(
#'   text = "str2lang(x)",
#'   linters = backport_linter("4.0.0")
#' )
#'
#' @evalRd rd_tags("backport_linter")
#' @seealso [linters] for a complete list of linters available in lintr.
#' @export
backport_linter <- function(r_version = getRversion(), except = character()) {
  r_version <- normalize_r_version(r_version)

  if (all(r_version >= R_system_version(names(backports)))) {
    return(Linter(function(source_expression) list(), linter_level = "file"))
  }

  backport_blacklist <- backports[r_version < R_system_version(names(backports))]
  backport_blacklist <- lapply(backport_blacklist, setdiff, except)
  backport_index <- rep(names(backport_blacklist), times = lengths(backport_blacklist))
  names(backport_index) <- unlist(backport_blacklist)

  Linter(linter_level = "expression", function(source_expression) {
    xml <- source_expression$xml_parsed_content

    used_symbols <- xml_find_all(xml, "//SYMBOL")
    used_symbols <- used_symbols[xml_text(used_symbols) %in% names(backport_index)]

    all_names_nodes <- combine_nodesets(
      source_expression$xml_find_function_calls(names(backport_index)),
      used_symbols
    )
    all_names <- xml_text(all_names_nodes)

    bad_versions <- unname(backport_index[all_names])

    lint_message <- sprintf(
      "%s (R %s) is not available for dependency R >= %s.",
      all_names,
      bad_versions,
      r_version
    )
    xml_nodes_to_lints(
      all_names_nodes,
      source_expression = source_expression,
      lint_message = lint_message,
      type = "warning"
    )
  })
}

normalize_r_version <- function(r_version) {
  rx_release_spec <- rex(
    start,
    "release" %or%
      list("oldrel", maybe("-", digits)) %or%
      "devel",
    end
  )
  if (is.character(r_version) && re_matches(r_version, rx_release_spec)) {
    # Support devel, release, oldrel, oldrel-1, ...
    if (r_version == "oldrel") {
      r_version <- "oldrel-1"
    }

    all_versions <- names(backports)
    minor_versions <- unique(re_substitutes(all_versions, rex(".", digits, end), ""))
    version_names <- c("devel", "release", paste0("oldrel-", seq_len(length(minor_versions) - 2L)))
    if (!r_version %in% version_names) {
      # This can only trip if e.g. oldrel-99 is requested
      stop("`r_version` must be a version number or one of ", toString(sQuote(version_names)), call. = FALSE)
    }
    requested_version <- minor_versions[match(r_version, table = version_names)]
    available_patches <- all_versions[startsWith(all_versions, requested_version)]
    selected_patch <- which.max(as.integer(
      substr(available_patches, start = nchar(requested_version) + 2L, stop = nchar(available_patches))
    ))

    r_version <- R_system_version(available_patches[selected_patch])
  } else if (is.character(r_version)) {
    r_version <- R_system_version(r_version, strict = TRUE)
  } else if (!inherits(r_version, "R_system_version")) {
    stop("`r_version` must be a R version number, returned by R_system_version(), or a string.", call. = FALSE)
  }
  if (r_version < "3.0.0") {
    warning(
      "It is not recommended to depend on an R version older than 3.0.0. Resetting 'r_version' to 3.0.0.",
      call. = FALSE
    )
    r_version <- R_system_version("3.0.0")
  }
  r_version
}

# Sources:
# devel NEWS https://cran.rstudio.com/doc/manuals/r-devel/NEWS.html
# release NEWS https://cran.r-project.org/doc/manuals/r-release/NEWS.html
backports <- list(
  `4.3.0` = c("R_compiled_by", "array2DF"),
  `4.2.1` = "findCRANmirror",
  `4.2.0` = c(".pretty", ".LC.categories", "Sys.setLanguage()"),
  `4.1.3` = character(), # need these for oldrel specifications
  `4.1.0` = c("numToBits", "numToInts", "gregexec", "charClass", "checkRdContents", "...names"),
  `4.0.5` = character(), # need these for oldrel specifications
  `4.0.0` = c(
    ".class2", ".S3method", "activeBindingFunction", "deparse1", "globalCallingHandlers",
    "infoRDS", "list2DF", "marginSums", "proportions", "R_user_dir", "socketTimeout", "tryInvokeRestart"
  ),
  `3.6.3` = character(), # need these for oldrel specifications
  `3.6.0` = c(
    "asplit", "hcl.colors", "hcl.pals", "mem.maxNsize", "mem.maxVsize", "nullfile", "str2lang",
    "str2expression", "update_PACKAGES"
  ),
  `3.5.3` = character(), # need these for oldrel specifications
  `3.5.0` = c("...elt", "...length", "askYesNo", "getDefaultCluster", "isFALSE", "packageDate", "warnErrList"),
  `3.4.4` = character(), # need these for oldrel specifications
  `3.4.0` = c(
    "check_packages_in_dir_details", "CRAN_package_db", "debugcall", "hasName",
    "isS3stdgeneric", "strcapture", "Sys.setFileTime", "undebugcall"
  ),
  `3.3.3` = character(), # need these for oldrel specifications
  `3.3.0` = c(
    ".traceback", "chkDots", "curlGetHeaders", "endsWith", "grouping", "isS3method",
    "makevars_site", "makevars_user", "Rcmd", "sigma", "startsWith", "strrep", "validEnc", "validUTF8"
  ),
  `3.2.5` = character(), # need these for oldrel specifications
  `3.2.0` = c(
    ".getNamespaceInfo", "check_packages_in_dir_changes", "debuggingState",
    "dir.exists", "dynGet", "extSoftVersion", "get0", "grSoftVersion", "hsearch_db",
    "isNamespaceLoaded", "lengths", "libcurlVersion", "returnValue", "tclVersion", "toTitleCase", "trimws"
  ),
  `3.1.3` = "pcre_config",
  `3.1.2` = "icuGetCollate",
  `3.1.1` = c(".nknots.smspl", "promptImport"),
  `3.1.0` = c("agrepl", "anyNA", "changedFiles", "cospi", "fileSnapshot", "find_gs_cmd", "sinpi", "tanpi"),
  `3.0.3` = "La_version",
  `3.0.2` = c("assertCondition", "assertError", "assertWarning", "getVignetteInfo"),
  `3.0.0` = c(
    ".onDetach", "bitwAnd", "bitwNot", "bitwOr", "bitwShiftL", "bitwShiftR", "bitwXor",
    "check_packages_in_dir", "cite", "citeNatbib", "clearPushBack", "packageName",
    "process.events", "provideDimnames", "quartz.save", "rep_len"
  )
)