| # File src/library/tools/R/QC.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2019 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| ## R CMD check uses |
| ## .find_charset |
| ## .check_namespace |
| ## .check_package_depends |
| ## .check_demo_index |
| ## .check_vignette_index |
| ## .check_package_subdirs |
| ## .check_citation |
| ## .check_package_ASCII_code |
| ## .check_package_code_syntax |
| ## .check_packages_used |
| ## .check_package_code_shlib |
| ## .check_package_code_startup_functions |
| ## .check_package_code_assign_to_globalenv |
| ## .check_package_code_attach |
| ## .check_package_code_data_into_globalenv |
| ## .check_code_usage_in_package |
| ## .check_T_and_F |
| ## .check_dotInternal |
| ## .check_package_parseRd |
| ## .check_Rd_xrefs |
| ## undoc |
| ## codoc |
| ## codocData |
| ## codocClasses |
| ## checkDocFiles |
| ## checkDocStyle |
| ## checkFF |
| ## checkReplaceFuns |
| ## checkS3methods |
| ## .check_package_datasets |
| ## .check_package_compact_datasets |
| ## .check_package_compact_sysdata |
| ## .check_make_vars |
| ## .createExdotR (testing.R) |
| ## .runPackageTestsR (testing.R) |
| ## .get_LaTeX_errors_from_log_file |
| ## .check_package_CRAN_incoming |
| ## .check_Rd_contents |
| |
| ## R CMD build uses .check_package_subdirs |
| |
| ## NB: 'tools' cannot use NAMESPACE imports from utils, as it exists first |
| |
| ## "The language elements" : all are .Primitive *and* print as .Primitive("...") |
| langElts <- c("(", "{", ":", "~", |
| "<-", "<<-", "=", |
| "[", "[[", "[[<-", "[<-", "@", "@<-", "$", "$<-", |
| "&&", "||", |
| "break", "for", "function", "if", "next", "repeat", "return", "while") |
| |
| ## Code "existing conceptually" in base, |
| ## typically function names of default methods for .Primitive s: |
| conceptual_base_code <- c("c.default") |
| |
| ##' a "default" print method used "below" (in several *.R): |
| .print.via.format <- function(x, ...) { |
| writeLines(format(x, ...)) |
| invisible(x) |
| } |
| |
| ## utility for whether Rd sources are available. |
| .haveRds <- function(dir) |
| { |
| ## either source package or pre-2.10.0 installed package |
| dir.exists (file.path(dir, "man")) || |
| file.exists(file.path(dir, "help", "paths.rds")) |
| } |
| |
| ### * undoc/F/out |
| |
| undoc <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Argument handling. |
| ## <NOTE> |
| ## Earlier versions used to give an error if there were no Rd |
| ## objects. This is not right: if there is code or data but no |
| ## documentation, everything is undocumented ... |
| ## </NOTE> |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dirdir <- dirname(dir <- find.package(package, lib.loc)) |
| ## Using package installed in @code{dir} ... |
| is_base <- package == "base" |
| |
| all_doc_topics <- Rd_aliases(package, lib.loc = dirdir) |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| |
| code_objs <- ls(envir = code_env, all.names = TRUE) |
| pkgname <- package |
| } |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| pkgname <- basename(dir) |
| dirdir <- dirname(dir) |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| is_base <- pkgname == "base" |
| |
| all_doc_topics <- Rd_aliases(dir = dir) |
| |
| code_env <- new.env(hash = TRUE) |
| code_dir <- file.path(dir, "R") |
| if(dir.exists(code_dir)) { |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| sys_data_file <- file.path(code_dir, "sysdata.rda") |
| if(file_test("-f", sys_data_file)) |
| load(sys_data_file, code_env) |
| } |
| |
| code_objs <- ls(envir = code_env, all.names = TRUE) |
| |
| ## Does the package have a NAMESPACE file? Note that when |
| ## working on the sources we (currently?) cannot deal with the |
| ## (experimental) alternative way of specifying the namespace. |
| if(file.exists(file.path(dir, "NAMESPACE"))) { |
| nsInfo <- parseNamespaceFile(pkgname, dirdir) |
| ## Look only at exported objects (and not declared S3 |
| ## methods). |
| OK <- intersect(code_objs, nsInfo$exports) |
| for(p in nsInfo$exportPatterns) |
| OK <- c(OK, grep(p, code_objs, value = TRUE)) |
| code_objs <- unique(OK) |
| } |
| } |
| |
| ## Find the data sets to work on. |
| data_dir <- file.path(dir, "data") |
| data_objs <- if(dir.exists(data_dir)) |
| unlist(.try_quietly(list_data_in_pkg(pkgname, dataDir = data_dir)), |
| use.names = FALSE) |
| else |
| character() |
| |
| ## There was a time when packages contained code or data (or both). |
| ## But not anymore ... |
| if(!missing(package) && !length(code_objs) && !length(data_objs) |
| && getOption("verbose")) |
| message("neither code nor data objects found") |
| |
| if(!is_base) { |
| ## Code objects in add-on packages with names starting with a |
| ## dot are considered 'internal' (not user-level) by |
| ## convention. |
| code_objs <- grep("^[^.].*", code_objs, value = TRUE) |
| ## Note that this also allows us to get rid of S4 meta objects |
| ## (with names starting with '.__C__' or '.__M__'; well, as long |
| ## as there are none in base). |
| |
| ## Implicit generic functions exist to turn method dispatch on |
| ## in this package, but their definition and documentation belongs |
| ## to the package in their package slot, so eliminate any |
| ## foreign generic functions from code_objs |
| if(.isMethodsDispatchOn()) { |
| is <- methods::is # speed |
| code_objs <- |
| Filter(function(f) { |
| fdef <- code_env[[f]] # faster than get() |
| ## Running methods::is() on data sets can trigger |
| ## loading additional packages for which startup |
| ## messages et al need suppressing ... |
| if(suppressMessages(is(fdef, "genericFunction"))) |
| fdef@package == pkgname |
| else |
| TRUE |
| }, |
| code_objs) |
| } |
| |
| ## Allow group generics to be undocumented other than in base. |
| ## In particular, those from methods partially duplicate base |
| ## and are documented in base's groupGenerics.Rd. |
| code_objs <- setdiff(code_objs, |
| c("Arith", "Compare", "Complex", "Logic", |
| "Math", "Math2", "Ops", "Summary")) |
| } |
| |
| undoc_things <- |
| list("code objects" = |
| unique(setdiff(code_objs, all_doc_topics)), |
| "data sets" = |
| unique(setdiff(data_objs, all_doc_topics))) |
| |
| if(.isMethodsDispatchOn()) { |
| ## Undocumented S4 classes? |
| S4_classes <- methods::getClasses(code_env) |
| ## <NOTE> |
| ## There is no point in worrying about exportClasses directives |
| ## in a NAMESPACE file when working on a package source dir, as |
| ## we only source the assignments, and hence do not get any |
| ## S4 classes or methods. |
| ## </NOTE> |
| ## The bad ones: |
| S4_classes <- |
| S4_classes[vapply(S4_classes, utils:::topicName, " ", |
| type = "class", USE.NAMES = FALSE) |
| %notin% all_doc_topics] |
| undoc_things <- |
| c(undoc_things, list("S4 classes" = unique(S4_classes))) |
| } |
| |
| if(.isMethodsDispatchOn()) { |
| ## Undocumented S4 methods? |
| ## <NOTE> |
| ## There is no point in worrying about exportMethods directives |
| ## in a NAMESPACE file when working on a package source dir, as |
| ## we only source the assignments, and hence do not get any |
| ## S4 classes or methods. |
| ## </NOTE> |
| .make_S4_method_siglist <- function(g) { |
| mlist <- .get_S4_methods_list(g, code_env) |
| sigs <- .make_siglist(mlist) # s/#/,/g |
| if(length(sigs)) |
| paste0(g, ",", sigs) |
| else |
| character() |
| } |
| S4_methods <- lapply(.get_S4_generics(code_env), |
| .make_S4_method_siglist) |
| S4_methods <- as.character(unlist(S4_methods, use.names = FALSE)) |
| |
| ## The bad ones: |
| S4_methods <- |
| S4_methods[vapply(S4_methods, utils:::topicName, " ", |
| type="method", USE.NAMES = FALSE) |
| %notin% all_doc_topics] |
| undoc_things <- |
| c(undoc_things, |
| list("S4 methods" = |
| unique(sub("([^,]*),(.*)", |
| "generic '\\1' and siglist '\\2'", |
| S4_methods)))) |
| } |
| if(is_base) { |
| ## We use .ArgsEnv and .GenericArgsEnv in checkS3methods() and |
| ## codoc(), so we check here that the set of primitives has not |
| ## been changed. |
| ff <- as.list(baseenv(), all.names=TRUE) |
| prims <- names(ff)[vapply(ff, is.primitive, logical(1L))] |
| prototypes <- sort(c(names(.ArgsEnv), names(.GenericArgsEnv))) |
| extras <- setdiff(prototypes, prims) |
| if(length(extras)) |
| undoc_things <- c(undoc_things, list(prim_extra=extras)) |
| miss <- setdiff(prims, c(langElts, prototypes)) |
| if(length(miss)) |
| undoc_things <- c(undoc_things, list(primitives=miss)) |
| } |
| |
| class(undoc_things) <- "undoc" |
| undoc_things |
| } |
| |
| format.undoc <- |
| function(x, ...) |
| { |
| .fmt <- function(i) { |
| tag <- names(x)[i] |
| msg <- switch(tag, |
| "code objects" = |
| gettext("Undocumented code objects:"), |
| "data sets" = |
| gettext("Undocumented data sets:"), |
| "S4 classes" = |
| gettext("Undocumented S4 classes:"), |
| "S4 methods" = |
| gettext("Undocumented S4 methods:"), |
| prim_extra = |
| gettext("Prototyped non-primitives:"), |
| gettextf("Undocumented %s:", tag)) |
| c(msg, |
| ## We avoid markup for indicating S4 methods, hence need to |
| ## special-case output for these ... |
| if(tag == "S4 methods") { |
| strwrap(x[[i]], indent = 2L, exdent = 4L) |
| } else { |
| .pretty_format(x[[i]]) |
| }) |
| } |
| |
| as.character(unlist(lapply(which(lengths(x) > 0L), .fmt))) |
| } |
| |
| ### * codoc |
| |
| ## |
| is_data_for_dataset <- function(e) ## trigger for data(foo) or data(foo, package="bar") and similar |
| length(e) >= 2L && e[[1L]] == quote(data) && e[[2L]] != quote(...) && length(e) <= 4L |
| |
| codoc <- |
| function(package, dir, lib.loc = NULL, |
| use.values = NULL, verbose = getOption("verbose")) |
| { |
| has_namespace <- FALSE |
| |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in @code{dir} ... |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", dir), |
| domain = NA) |
| if(!.haveRds(dir)) |
| stop(gettextf("directory '%s' does not contain Rd objects", dir), |
| domain = NA) |
| is_base <- basename(dir) == "base" |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| |
| objects_in_code <- sort(names(code_env)) |
| |
| dirdir <- dirname(dir) |
| ## Does the package have a namespace? |
| if(packageHasNamespace(package, dirdir)) { |
| has_namespace <- TRUE |
| ns_env <- asNamespace(package) |
| S3Table <- get(".__S3MethodsTable__.", envir = ns_env) |
| functions_in_S3Table <- ls(S3Table, all.names = TRUE) |
| objects_in_ns <- |
| setdiff(sort(names(ns_env)), |
| c(".__NAMESPACE__.", ".__S3MethodsTable__.")) |
| ns_S3_methods_db <- getNamespaceInfo(package, "S3methods") |
| ns_S3_methods <- if(is.null(ns_S3_methods_db)) |
| character() |
| else |
| paste(ns_S3_methods_db[, 1L], |
| ns_S3_methods_db[, 2L], |
| sep = ".") |
| objects_in_code_or_namespace <- |
| unique(c(objects_in_code, objects_in_ns, ns_S3_methods)) |
| objects_in_ns <- setdiff(objects_in_ns, objects_in_code) |
| } |
| else { ## typically only 'base' |
| objects_in_code_or_namespace <- objects_in_code |
| } |
| package_name <- package |
| } |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), domain = NA) |
| ## else |
| package_name <- basename(dir) # early, before resolving sym.links etc in next line: |
| dirdir <- dirname(dir) # early, ... |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", dir), |
| domain = NA) |
| if(!.haveRds(dir)) |
| stop(gettextf("directory '%s' does not contain Rd objects", dir), |
| domain = NA) |
| is_base <- package_name == "base" |
| |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) .read_description(dfile) else character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| sys_data_file <- file.path(code_dir, "sysdata.rda") |
| if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) |
| |
| objects_in_code <- sort(names(code_env)) |
| objects_in_code_or_namespace <- objects_in_code |
| |
| ## Does the package have a NAMESPACE file? Note that when |
| ## working on the sources we (currently?) cannot deal with the |
| ## (experimental) alternative way of specifying the namespace. |
| ## Also, do not attempt to find S3 methods. |
| if(file.exists(file.path(dir, "NAMESPACE"))) { |
| has_namespace <- TRUE |
| objects_in_ns <- objects_in_code |
| functions_in_S3Table <- character() |
| ns_env <- code_env |
| nsInfo <- parseNamespaceFile(package_name, dirdir) |
| ## Look only at exported objects. |
| OK <- intersect(objects_in_code, nsInfo$exports) |
| for(p in nsInfo$exportPatterns) |
| OK <- c(OK, grep(p, objects_in_code, value = TRUE)) |
| objects_in_code <- unique(OK) |
| } |
| } |
| |
| ## Find the data sets to work on. |
| data_dir <- file.path(dir, "data") |
| data_sets_in_code <- if(dir.exists(data_dir)) |
| names(.try_quietly(list_data_in_pkg(package_name, dataDir = data_dir))) |
| else |
| character() |
| |
| ## Find the function objects to work on. |
| functions_in_code <- |
| Filter(function(f) { |
| ## This is expensive |
| f <- get(f, envir = code_env) |
| typeof(f) == "closure" |
| }, |
| objects_in_code) |
| ## Sourcing all R code files in the package is a problem for base, |
| ## where this misses the .Primitive functions. Hence, when checking |
| ## base for objects shown in \usage but missing from the code, we |
| ## get the primitive functions from the version of R we are using. |
| ## Maybe one day we will have R code for the primitives as well ... |
| ## As from R 2.5.0 we do for most generics. |
| if(is_base) { |
| objects_in_base <- |
| sort(names(baseenv())) |
| objects_in_code <- |
| c(objects_in_code, |
| conceptual_base_code, |
| Filter(.is_primitive_in_base, objects_in_base), |
| c(".First.lib", ".Last.lib", ".Random.seed", |
| ".onLoad", ".onAttach", ".onDetach", ".onUnload")) |
| objects_in_code_or_namespace <- objects_in_code |
| known_env <- .make_S3_primitive_generic_env(code_env, fixup=TRUE) |
| extras <- ls(known_env, all.names = TRUE) |
| functions_in_code <- c(functions_in_code, extras) |
| code_env <- known_env |
| known_env <- .make_S3_primitive_nongeneric_env(code_env) |
| extras <- ls(known_env, all.names = TRUE) |
| functions_in_code <- c(functions_in_code, extras) |
| code_env <- known_env |
| } |
| |
| ## Build a list with the formals of the functions in the code |
| ## indexed by the names of the functions. |
| function_args_in_code <- |
| lapply(functions_in_code, |
| function(f) formals(get(f, envir = code_env))) # get is expensive |
| names(function_args_in_code) <- functions_in_code |
| if(has_namespace) { |
| functions_in_ns <- |
| Filter(function(f) { |
| f <- get(f, envir = ns_env) # get is expensive |
| is.function(f) && (length(formals(f)) > 0L) |
| }, |
| objects_in_ns) |
| function_args_in_ns <- |
| lapply(functions_in_ns, |
| function(f) formals(get(f, envir = ns_env))) |
| names(function_args_in_ns) <- functions_in_ns |
| |
| function_args_in_S3Table <- |
| lapply(functions_in_S3Table, |
| function(f) formals(get(f, envir = S3Table))) |
| names(function_args_in_S3Table) <- functions_in_S3Table |
| |
| tmp <- c(function_args_in_code, function_args_in_S3Table, |
| function_args_in_ns) |
| keep <- !duplicated(names(tmp)) |
| function_args_in_code <- tmp[keep] |
| functions_in_code <- names(function_args_in_code) |
| } |
| if(.isMethodsDispatchOn()) { |
| ## <NOTE> |
| ## There is no point in worrying about exportMethods directives |
| ## in a NAMESPACE file when working on a package source dir, as |
| ## we only source the assignments, and hence do not get any |
| ## S4 classes or methods. |
| ## </NOTE> |
| ## <NOTE> |
| ## In principle, we can get codoc checking for S4 methods |
| ## documented explicitly using the \S4method{GENERIC}{SIGLIST} |
| ## markup by adding the corresponding "pseudo functions" using |
| ## the Rd markup as their name. However note that the formals |
| ## recorded in the methods db only pertain to the signature, not |
| ## to the ones of the function actually registered ... hence we |
| ## use methods::unRematchDefinition() which knows how to extract |
| ## the formals in the method definition from the |
| ## function(ARGLIST) { |
| ## .local <- function(FORMALS) BODY |
| ## .local(ARGLIST) |
| ## } |
| ## redefinitions obtained by methods::rematchDefinition(). |
| ## </NOTE> |
| check_S4_methods <- |
| !identical(as.logical(Sys.getenv("_R_CHECK_CODOC_S4_METHODS_")), |
| FALSE) |
| if(check_S4_methods) { |
| unRematchDef <- methods::unRematchDefinition |
| get_formals_from_method_definition <- function(m) |
| formals(unRematchDef(m)) |
| lapply(.get_S4_generics(code_env), |
| function(f) { |
| mlist <- .get_S4_methods_list(f, code_env) |
| sigs <- .make_siglist(mlist) |
| if(!length(sigs)) return() |
| nm <- sprintf("\\S4method{%s}{%s}", f, sigs) |
| args <- lapply(mlist, |
| get_formals_from_method_definition) |
| names(args) <- nm |
| functions_in_code <<- |
| c(functions_in_code, nm) |
| function_args_in_code <<- |
| c(function_args_in_code, args) |
| }) |
| } |
| } |
| |
| check_codoc <- function(fName, ffd) { |
| ## Compare the formals of the function in the code named 'fName' |
| ## and formals 'ffd' obtained from the documentation. |
| ffc <- function_args_in_code[[fName]] |
| if(isFALSE(use.values)) { |
| ffc <- names(ffc) |
| ffd <- names(ffd) |
| ok <- identical(ffc, ffd) |
| } else { |
| if(!identical(names(ffc), names(ffd))) |
| ok <- FALSE |
| else { |
| vffc <- as.character(ffc) # values |
| vffd <- as.character(ffd) # values |
| if(!isTRUE(use.values)) { |
| ind <- nzchar(as.character(ffd)) |
| vffc <- vffc[ind] |
| vffd <- vffd[ind] |
| } |
| ok <- identical(vffc, vffd) |
| } |
| } |
| if(ok) |
| NULL |
| else |
| list(list(name = fName, code = ffc, docs = ffd)) |
| } |
| |
| db <- if(!missing(package)) |
| Rd_db(package, lib.loc = dirdir) |
| else |
| Rd_db(dir = dir) |
| |
| names(db) <- db_names <- .Rd_get_names_from_Rd_db(db) |
| |
| ## pkg-defunct.Rd is not expected to list arguments |
| ind <- db_names %in% paste0(package_name, "-defunct") |
| db <- db[!ind] |
| db_names <- db_names[!ind] |
| |
| db_usages <- lapply(db, .Rd_get_section, "usage") |
| ## FIXME: all db_usages entries are full of "srcref" which are never used |
| db_usages <- lapply(db_usages, .parse_usage_as_much_as_possible) |
| ind <- vapply(db_usages, |
| function(x) !is.null(attr(x, "bad_lines")), NA, USE.NAMES=FALSE) |
| bad_lines <- lapply(db_usages[ind], attr, "bad_lines") |
| |
| bad_doc_objects <- list() |
| functions_in_usages <- character() |
| variables_in_usages <- character() |
| data_sets_in_usages <- character() |
| functions_in_usages_not_in_code <- list() |
| data_sets_in_usages_not_in_code <- list() |
| objects_in_other_platforms <- names(compatibilityEnv()) |
| objects_as_in <- c(objects_in_code_or_namespace, |
| objects_in_other_platforms) |
| |
| for(docObj in db_names) { |
| exprs <- db_usages[[docObj]] |
| if(!length(exprs)) next |
| |
| ## Get variable names and data set usages first, mostly for |
| ## curiosity. |
| ind <- ! vapply(exprs, is.call, NA) |
| if(any(ind)) { |
| variables_in_usages <- |
| c(variables_in_usages, |
| sapply(exprs[ind], deparse)) |
| exprs <- exprs[!ind] |
| } |
| ind <- vapply(exprs, is_data_for_dataset, NA, USE.NAMES=FALSE) |
| if(any(ind)) { |
| data_sets <- sapply(exprs[ind], |
| function(e) as.character(e[[2L]])) |
| data_sets_in_usages <- c(data_sets_in_usages, data_sets) |
| data_sets <- setdiff(data_sets, data_sets_in_code) |
| if(length(data_sets)) |
| data_sets_in_usages_not_in_code[[docObj]] <- data_sets |
| exprs <- exprs[!ind] |
| } |
| ## Split out replacement function usages. |
| ind <- vapply(exprs, .is_call_from_replacement_function_usage, NA, USE.NAMES=FALSE) |
| replace_exprs <- exprs[ind] |
| exprs <- exprs[!ind] |
| ## Ordinary functions. |
| functions <- vapply(exprs, function(e) as.character(e[[1L]]), "") |
| ## Catch assignments: checkDocFiles() will report these, so drop |
| ## them here. |
| ## And also unary/binary operators |
| ind <- (functions %notin% c("<-", "=", "+", "-")) |
| exprs <- exprs[ind] |
| functions <- functions[ind] |
| functions <- .transform_S3_method_markup(as.character(functions)) |
| ind <- functions %in% functions_in_code |
| bad_functions <- |
| mapply(functions[ind], |
| exprs[ind], |
| FUN = function(x, y) |
| check_codoc(x, as.pairlist(as.alist.call(y[-1L]))), |
| SIMPLIFY = FALSE) |
| ## Replacement functions. |
| if(length(replace_exprs)) { |
| replace_funs <- |
| paste0(sapply(replace_exprs, |
| function(e) as.character(e[[2L]][[1L]])), |
| "<-") |
| replace_funs <- .transform_S3_method_markup(replace_funs) |
| functions <- c(functions, replace_funs) |
| ind <- (replace_funs %in% functions_in_code) |
| if(any(ind)) { |
| bad_replace_funs <- |
| mapply(replace_funs[ind], |
| replace_exprs[ind], |
| FUN = function(x, y) |
| check_codoc(x, |
| as.pairlist(c(as.alist.call(y[[2L]][-1L]), |
| as.alist.symbol(y[[3L]])))), |
| SIMPLIFY = FALSE) |
| bad_functions <- |
| c(bad_functions, bad_replace_funs) |
| } |
| } |
| |
| bad_functions <- do.call("c", bad_functions) |
| if(length(bad_functions)) |
| bad_doc_objects[[docObj]] <- bad_functions |
| |
| ## Determine functions with a \usage entry in the documentation |
| ## but 'missing from the code'. If a package has a namespace, we |
| ## really need to look at all objects in the namespace (hence |
| ## 'objects_as_in' contains 'objects_in_code_or_namespace'), |
| ## as one can access the internal |
| ## symbols via ':::' and hence package developers might want to |
| ## provide function usages for some of the internal functions. |
| ## <FIXME> |
| ## We may still have \S4method{}{} entries in functions, which |
| ## cannot have a corresponding object in the code. Hence, we |
| ## remove these function entries, but should really do better, |
| ## by comparing the explicit \usage entries for S4 methods to |
| ## what is actually in the code. We most likely also should do |
| ## something similar for S3 methods. |
| ind <- grepl(.S4_method_markup_regexp, functions) |
| if(any(ind)) |
| functions <- functions[!ind] |
| ## </FIXME> |
| bad_functions <- setdiff(functions, objects_as_in) |
| if(length(bad_functions)) |
| functions_in_usages_not_in_code[[docObj]] <- bad_functions |
| |
| functions_in_usages <- c(functions_in_usages, functions) |
| } |
| |
| ## Determine (function) objects in the code without a \usage entry. |
| ## Of course, these could still be 'documented' via \alias. |
| ## </NOTE> |
| ## Older versions only printed this information without returning it |
| ## (in case 'verbose' was true). We now add this as an attribute to |
| ## the bad_doc_objects returned. |
| ## </NOTE> |
| objects_in_code_not_in_usages <- |
| setdiff(objects_in_code, |
| c(functions_in_usages, variables_in_usages)) |
| functions_in_code_not_in_usages <- |
| intersect(functions_in_code, objects_in_code_not_in_usages) |
| ## (Note that 'functions_in_code' does not necessarily contain all |
| ## (exported) functions in the package.) |
| |
| ## Determine functions which have no usage but really should have. |
| ## If there is no namespace (including base), we have no idea. |
| ## If there is one, everything "exported" (in the package env) |
| ## should also have a \usage, apart from |
| ## * Defunct functions |
| ## * S4 generics. Note that as per R-exts, |
| ## exporting methods on a generic in the namespace will also |
| ## export the generic, and exporting a generic in the namespace |
| ## will also export its methods. |
| ## so it seems there is really no way to figure out whether an |
| ## exported S4 generic should have a \usage entry or not ... |
| functions_missing_from_usages <- |
| if(!has_namespace) character() else { |
| functions <- functions_in_code_not_in_usages |
| if(.isMethodsDispatchOn()) { |
| ## Drop the functions which have S4 methods. |
| functions <- |
| setdiff(functions, names(.get_S4_generics(code_env))) |
| } |
| ## Drop the defunct functions. |
| is_defunct <- function(f) { |
| f <- get(f, envir = code_env) # get is expensive |
| if(!is.function(f)) return(FALSE) |
| (is.call(b <- body(f)) |
| && identical(as.character(b[[1L]]), ".Defunct")) |
| } |
| functions[!vapply(functions, is_defunct, NA, USE.NAMES=FALSE)] |
| } |
| objects_missing_from_usages <- |
| if(!has_namespace) character() else { |
| c(functions_missing_from_usages, |
| setdiff(objects_in_code_not_in_usages, |
| c(functions_in_code, data_sets_in_code))) |
| } |
| |
| attr(bad_doc_objects, "objects_in_code_not_in_usages") <- |
| objects_in_code_not_in_usages |
| attr(bad_doc_objects, "functions_in_code_not_in_usages") <- |
| functions_in_code_not_in_usages |
| attr(bad_doc_objects, "functions_in_usages_not_in_code") <- |
| functions_in_usages_not_in_code |
| attr(bad_doc_objects, "function_args_in_code") <- |
| function_args_in_code |
| attr(bad_doc_objects, "data_sets_in_usages_not_in_code") <- |
| data_sets_in_usages_not_in_code |
| attr(bad_doc_objects, "objects_missing_from_usages") <- |
| objects_missing_from_usages |
| attr(bad_doc_objects, "functions_missing_from_usages") <- |
| functions_missing_from_usages |
| attr(bad_doc_objects, "has_namespace") <- has_namespace |
| attr(bad_doc_objects, "bad_lines") <- bad_lines |
| class(bad_doc_objects) <- "codoc" |
| bad_doc_objects |
| } |
| |
| print.codoc <- |
| function(x, ...) |
| { |
| functions_in_usages_not_in_code <- |
| attr(x, "functions_in_usages_not_in_code") |
| if(length(functions_in_usages_not_in_code)) { |
| for(fname in names(functions_in_usages_not_in_code)) { |
| writeLines(gettextf("Functions or methods with usage in documentation object '%s' but not in code:", |
| fname)) |
| .pretty_print(sQuote(unique(functions_in_usages_not_in_code[[fname]]))) |
| writeLines("") |
| } |
| } |
| |
| data_sets_in_usages_not_in_code <- |
| attr(x, "data_sets_in_usages_not_in_code") |
| if(length(data_sets_in_usages_not_in_code)) { |
| for(fname in names(data_sets_in_usages_not_in_code)) { |
| writeLines(gettextf("Data with usage in documentation object '%s' but not in code:", |
| fname)) |
| .pretty_print(sQuote(unique(data_sets_in_usages_not_in_code[[fname]]))) |
| writeLines("") |
| } |
| } |
| |
| ## In general, functions in the code which only have an \alias but |
| ## no \usage entry are not necessarily a problem---they might be |
| ## mentioned in other parts of the Rd object documenting them, or be |
| ## 'internal'. However, if a package has a namespace, then all |
| ## *exported* functions should have \usage entries (apart from |
| ## defunct functions and S4 generics, see the above comments for |
| ## functions_missing_from_usages). Currently, this information is |
| ## returned in the codoc object but not shown. Eventually, we might |
| ## add something like |
| ## functions_missing_from_usages <- |
| ## attr(x, "functions_missing_from_usages") |
| ## if(length(functions_missing_from_usages)) { |
| ## writeLines("Exported functions without usage information:") |
| ## .pretty_print(functions_in_code_not_in_usages) |
| ## writeLines("") |
| ## } |
| ## similar to the above. |
| |
| if(!length(x)) |
| return(invisible(x)) |
| |
| has_only_names <- is.character(x[[1L]][[1L]][["code"]]) |
| |
| format_args <- function(s) { |
| if(!length(s)) |
| "function()" |
| else if(has_only_names) |
| paste0("function(", paste(s, collapse = ", "), ")") |
| else { |
| s <- paste(deparse(s), collapse = "") |
| s <- gsub(" = ([,\\)])", "\\1", s) |
| s <- gsub("<unescaped bksl>", "\\", s, fixed = TRUE) |
| s <- gsub("^pairlist", "function", s) |
| gsub("^as.pairlist\\(alist\\((.*)\\)\\)$", "function(\\1)", s) |
| } |
| } |
| |
| summarize_mismatches_in_names <- function(nfc, nfd) { |
| if(length(nms <- setdiff(nfc, nfd))) |
| writeLines(c(gettext(" Argument names in code not in docs:"), |
| strwrap(paste(nms, collapse = " "), |
| indent = 4L, exdent = 4L))) |
| if(length(nms <- setdiff(nfd, nfc))) |
| writeLines(c(gettext(" Argument names in docs not in code:"), |
| strwrap(paste(nms, collapse = " "), |
| indent = 4L, exdent = 4L))) |
| len <- min(length(nfc), length(nfd)) |
| if(len) { |
| len <- seq_len(len) |
| nfc <- nfc[len] |
| nfd <- nfd[len] |
| ind <- which(nfc != nfd) |
| len <- length(ind) |
| if(len) { |
| if(len > 3L) { |
| writeLines(gettext(" Mismatches in argument names (first 3):")) |
| ind <- ind[1L:3L] |
| } else { |
| writeLines(gettext(" Mismatches in argument names:")) |
| } |
| for(i in ind) { |
| writeLines(sprintf(" Position: %d Code: %s Docs: %s", |
| i, nfc[i], nfd[i])) |
| } |
| } |
| } |
| } |
| |
| summarize_mismatches_in_values <- function(ffc, ffd) { |
| ## Be nice, and match arguments by names first. |
| nms <- intersect(names(ffc), names(ffd)) |
| vffc <- ffc[nms] |
| vffd <- ffd[nms] |
| ind <- which(as.character(vffc) != as.character(vffd)) |
| len <- length(ind) |
| if(len) { |
| if(len > 3L) { |
| writeLines(gettext(" Mismatches in argument default values (first 3):")) |
| ind <- ind[1L:3L] |
| } else { |
| writeLines(gettext(" Mismatches in argument default values:")) |
| } |
| for(i in ind) { |
| multiline <- FALSE |
| cv <- deparse(vffc[[i]]) |
| if(length(cv) > 1L) { |
| cv <- paste(cv, collapse = "\n ") |
| multiline <- TRUE |
| } |
| dv <- deparse(vffd[[i]]) |
| if(length(dv) > 1L) { |
| dv <- paste(dv, collapse = "\n ") |
| multiline <- TRUE |
| } |
| dv <- gsub("<unescaped bksl>", "\\", dv, fixed = TRUE) |
| sep <- if(multiline) "\n " else " " |
| writeLines(sprintf(" Name: '%s'%sCode: %s%sDocs: %s", |
| nms[i], sep, cv, sep, dv)) |
| } |
| } |
| } |
| |
| summarize_mismatches <- function(ffc, ffd) { |
| if(has_only_names) |
| summarize_mismatches_in_names(ffc, ffd) |
| else { |
| summarize_mismatches_in_names(names(ffc), names(ffd)) |
| summarize_mismatches_in_values(ffc, ffd) |
| } |
| } |
| |
| for(fname in names(x)) { |
| writeLines(gettextf("Codoc mismatches from documentation object '%s':", |
| fname)) |
| xfname <- x[[fname]] |
| for(i in seq_along(xfname)) { |
| ffc <- xfname[[i]][["code"]] |
| ffd <- xfname[[i]][["docs"]] |
| writeLines(c(xfname[[i]][["name"]], |
| strwrap(gettextf("Code: %s", format_args(ffc)), |
| indent = 2L, exdent = 17L), |
| strwrap(gettextf("Docs: %s", format_args(ffd)), |
| indent = 2L, exdent = 17L))) |
| summarize_mismatches(ffc, ffd) |
| } |
| writeLines("") |
| } |
| |
| invisible(x) |
| } |
| |
| ### * codocClasses |
| |
| codocClasses <- |
| function(package, lib.loc = NULL) |
| { |
| ## Compare the 'structure' of S4 classes in an installed package |
| ## between code and documentation. |
| ## Currently, only compares the slot names. |
| |
| ## <NOTE> |
| ## This is patterned after the current codoc(). |
| ## It would be useful to return the whole information on class slot |
| ## names found in the code and matching documentation (rather than |
| ## just the ones with mismatches). |
| ## Currently, we only return the names of all classes checked. |
| ## </NOTE> |
| |
| bad_Rd_objects <- structure(list(), class = "codocClasses") |
| |
| ## Argument handling. |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| if(!dir.exists(file.path(dir, "R"))) |
| stop(gettextf("directory '%s' does not contain R code", dir), |
| domain = NA) |
| if(!.haveRds(dir)) |
| stop(gettextf("directory '%s' does not contain Rd objects", dir), |
| domain = NA) |
| is_base <- basename(dir) == "base" |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| |
| if(!.isMethodsDispatchOn()) |
| return(bad_Rd_objects) |
| |
| S4_classes <- methods::getClasses(code_env) |
| if(!length(S4_classes)) return(bad_Rd_objects) |
| |
| sApply <- function(X, FUN, ...) ## fast and special case - only |
| unlist(lapply(X = X, FUN = FUN, ...), recursive=FALSE, use.names=FALSE) |
| ## Build Rd data base. |
| db <- Rd_db(package, lib.loc = dirname(dir)) |
| |
| ## Need some heuristics now. When does an Rd object document just |
| ## one S4 class so that we can compare (at least) the slot names? |
| ## Try the following: |
| ## 1) \docType{} identical to "class"; |
| ## 2) either exactly one \alias{} or only one ending in "-class" |
| ## 3) a non-empty user-defined section 'Slots'. |
| |
| ## As going through the db to extract sections can take some time, |
| ## we do the vectorized metadata computations first, and try to |
| ## subscript whenever possible. |
| |
| idx <- vapply(lapply(db, .Rd_get_doc_type), identical, NA, "class", |
| USE.NAMES=FALSE) |
| if(!any(idx)) return(bad_Rd_objects) |
| db <- db[idx] |
| stats <- c(n.S4classes = length(S4_classes), n.db = length(db)) |
| |
| aliases <- lapply(db, .Rd_get_metadata, "alias") |
| named_class <- lapply(aliases, endsWith, suffix="-class") |
| nClass <- sApply(named_class, sum) |
| oneAlias <- lengths(aliases, use.names=FALSE) == 1L |
| idx <- oneAlias | nClass == 1L |
| if(!any(idx)) return(bad_Rd_objects) |
| db <- db[idx] |
| stats["n.cl"] <- length(db) |
| |
| ## keep only the foo-class alias in case there was more than one: |
| multi <- idx & !oneAlias |
| aliases[multi] <- |
| mapply(`[`, aliases[multi], named_class[multi], |
| SIMPLIFY = FALSE, USE.NAMES = FALSE) |
| aliases <- unlist(aliases[idx], use.names = FALSE) |
| |
| Rd_slots <- lapply(db, .Rd_get_section, "Slots", FALSE) |
| idx <- lengths(Rd_slots) > 0L |
| if(!any(idx)) return(bad_Rd_objects) |
| db <- db[idx]; aliases <- aliases[idx]; Rd_slots <- Rd_slots[idx] |
| stats["n.final"] <- length(db) |
| |
| db_names <- .Rd_get_names_from_Rd_db(db) |
| |
| .get_slot_names <- function(x) { |
| ## Get \describe (inside user-defined section 'Slots'): |
| ## Should this allow for several \describe blocks? |
| x <- .Rd_get_section(x, "describe") |
| ## Get the \item tags inside \describe. |
| txt <- .Rd_get_item_tags(x) |
| if(!length(txt)) return(character()) |
| txt <- gsub("\\\\l?dots", "...", txt) |
| ## And now strip enclosing '\code{...}:' |
| txt <- gsub("\\\\code\\{([^}]*)\\}:?", "\\1", as.character(txt)) |
| txt <- unlist(strsplit(txt, ", *")) |
| trimws(txt) |
| } |
| |
| .inheritedSlotNames <- function(ext) { |
| supcl <- methods::.selectSuperClasses(ext) |
| unique(unlist(lapply(lapply(supcl, methods::getClassDef), |
| methods::slotNames), |
| use.names=FALSE)) |
| } |
| |
| S4topics <- vapply(S4_classes, utils:::topicName, " ", |
| type="class", USE.NAMES=FALSE) |
| S4_checked <- S4_classes[has.a <- S4topics %in% aliases] |
| idx <- match(S4topics[has.a], aliases) |
| for(icl in seq_along(S4_checked)) { |
| cl <- S4_checked[icl] |
| cld <- methods::getClass(cl, where = code_env) |
| ii <- idx[icl] |
| ## Add sanity checking later ... |
| scld <- methods::slotNames(cld) |
| codeSlots <- if(!is.null(scld)) sort(scld) else character() |
| docSlots <- sort(.get_slot_names(Rd_slots[[ii]])) |
| superSlots <- .inheritedSlotNames(cld@contains) |
| if(length(superSlots)) ## allow '\dots' in docSlots |
| docSlots <- |
| docSlots[is.na(match(docSlots, c("...", "\\dots")))] |
| ## was if(!identical(slots_in_code, slots_in_docs)) { |
| if(!all(docSlots %in% codeSlots) || |
| !all(setdiff(codeSlots, superSlots) %in% docSlots) ) { |
| bad_Rd_objects[[db_names[ii]]] <- |
| list(name = cl, |
| code = codeSlots, |
| inherited = superSlots, |
| docs = docSlots) |
| } |
| } |
| |
| attr(bad_Rd_objects, "S4_classes_checked") <- S4_checked |
| attr(bad_Rd_objects, "stats") <- stats |
| bad_Rd_objects |
| } ## end{ codocClasses } |
| |
| format.codocClasses <- |
| function(x, ...) |
| { |
| .fmt <- function(nm) { |
| wrapPart <- function(nam) { |
| capWord <- function(w) sub("\\b(\\w)", "\\U\\1", w, perl = TRUE) |
| |
| if(length(O <- docObj[[nam]])) |
| strwrap(sprintf("%s: %s", gettextf(capWord(nam)), |
| paste(O, collapse = " ")), |
| indent = 2L, exdent = 8L) |
| } |
| |
| docObj <- x[[nm]] |
| c(gettextf("S4 class codoc mismatches from documentation object '%s':", |
| nm), |
| gettextf("Slots for class '%s'", docObj[["name"]]), |
| wrapPart("code"), |
| wrapPart("inherited"), |
| wrapPart("docs"), |
| "") |
| } |
| |
| as.character(unlist(lapply(names(x), .fmt))) |
| } |
| |
| ### * codocData |
| |
| codocData <- |
| function(package, lib.loc = NULL) |
| { |
| ## Compare the 'structure' of 'data' objects (variables or data |
| ## sets) in an installed package between code and documentation. |
| ## Currently, only compares the variable names of data frames found. |
| |
| ## <NOTE> |
| ## This is patterned after the current codoc(). |
| ## It would be useful to return the whole information on data frame |
| ## variable names found in the code and matching documentation |
| ## (rather than just the ones with mismatches). |
| ## Currently, we only return the names of all data frames checked. |
| ## </NOTE> |
| |
| bad_Rd_objects <- structure(list(), class = "codocData") |
| |
| ## Argument handling. |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| |
| dir <- find.package(package, lib.loc) |
| |
| ## Build Rd data base. |
| db <- Rd_db(package, lib.loc = dirname(dir)) |
| |
| is_base <- basename(dir) == "base" |
| has_namespace <- !is_base && packageHasNamespace(package, dirname(dir)) |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| if(has_namespace) ns_env <- asNamespace(package) |
| |
| ## Could check here whether the package has any variables or data |
| ## sets (and return if not). |
| |
| |
| ## Need some heuristics now. When does an Rd object document a |
| ## data.frame (could add support for other classes later) variable |
| ## or data set so that we can compare (at least) the names of the |
| ## variables in the data frame? Try the following: |
| ## * just one \alias{}; |
| ## * if documentation was generated via prompt, there is a \format |
| ## section starting with 'A data frame with' (but many existing Rd |
| ## files instead have 'This data frame contains' and containing |
| ## one or more \describe sections inside. |
| |
| ## As going through the db to extract sections can take some time, |
| ## we do the vectorized metadata computations first, and try to |
| ## subscript whenever possible. |
| aliases <- lapply(db, .Rd_get_metadata, "alias") |
| idx <- lengths(aliases) == 1L |
| if(!any(idx)) return(bad_Rd_objects) |
| db <- db[idx] |
| aliases <- aliases[idx] |
| |
| names(db) <- .Rd_get_names_from_Rd_db(db) |
| |
| .get_var_names_from_item_tags <- function(s, nice = TRUE) { |
| if(!length(s)) return(character()) |
| |
| nms <- character() |
| ## Handle trailing colons and leading/trailing white space. |
| s <- sub("^ *", "", sub("( *:)? *$", "", s)) |
| ## Handle \samp entries: need to match until the first unescaped |
| ## rbrace. |
| re <- "\\\\samp\\{(([^\\}]|[\\].)*)\\}( *, *)?" |
| m <- gregexpr(re, s) |
| if(any(unlist(m) > -1)) { |
| nms <- sub(re, "\\1", unlist(regmatches(s, m))) |
| ## Unescape Rd escapes. |
| nms <- gsub("\\\\([{}%])", "\\1", nms) |
| regmatches(s, m) <- "" |
| } |
| ## Handle \code entries, assuming that they can be taken literally |
| ## (no escaping or quoting to obtain valid R syntax). |
| re <- "\\\\code\\{([^}]*)\\}( *, *)?" |
| m <- gregexpr(re, s) |
| add <- regmatches(s, m) |
| lens <- lengths(add) |
| add <- sub(re, "\\1", unlist(add)) |
| ## The old code base simply dropped the \code markup via |
| ## gsub("\\\\code\\{(.*)\\}:?", "\\1", s) |
| ## unescaped underscores and stripped whitespace. |
| ## Let us be nice about such whitespace inside a single \code (by |
| ## default), as this should always render ok in the manual, but not |
| ## about escaped underscores e.g., |
| ## ElemStatLearn/man/marketing.Rd: Dual\_Income |
| ## and comma-separated lists inside |
| ## \code, e.g., |
| ## prefmod/man/trdel.Rd: \code{V1,V2,V3,V4,V5,V6,V7,V8,V9,V10} |
| ## as these will not render correctly. |
| if(nice) { |
| ind <- rep.int(lens == 1L, lens) |
| add[ind] <- trimws(add[ind]) |
| } |
| nms <- c(nms, add) |
| regmatches(s, m) <- "" |
| ## Handle rest. |
| nms <- c(nms, unlist(strsplit(s, " *, *"))) |
| nms |
| } |
| |
| .get_data_frame_var_names <- function(x) { |
| ## Make sure that there is exactly one format section: |
| ## using .Rd_get_section() would get the first one. |
| x <- x[RdTags(x) == "\\format"] |
| if(length(x) != 1L) return(character()) |
| ## Drop comments. |
| ## <FIXME> |
| ## Remove calling .Rd_drop_comments() eventually. |
| x <- .Rd_drop_comments(x[[1L]]) |
| ## </FIXME> |
| ## What did the format section start with? |
| if(!grepl("^[ \n\t]*(A|This) data frame", |
| .Rd_deparse(x, tag = FALSE))) |
| return(character()) |
| ## Get \describe inside \format. |
| ## Should this allow for several \describe blocks? |
| x <- .Rd_get_section(x, "describe") |
| ## Get the \item tags inside \describe. |
| x <- .Rd_get_item_tags(x) |
| ## And extract the variable names from these. |
| .get_var_names_from_item_tags(x) |
| } |
| |
| Rd_var_names <- lapply(db, .get_data_frame_var_names) |
| |
| idx <- (lengths(Rd_var_names) > 0L) |
| if(!length(idx)) return(bad_Rd_objects) |
| aliases <- unlist(aliases[idx]) |
| Rd_var_names <- Rd_var_names[idx] |
| |
| db_names <- names(db)[idx] |
| |
| data_env <- new.env(hash = TRUE) |
| data_dir <- file.path(dir, "data") |
| ## with lazy data we have data() but don't need to use it. |
| has_data <- dir.exists(data_dir) && |
| !file_test("-f", file.path(data_dir, "Rdata.rdb")) |
| data_exts <- .make_file_exts("data") |
| |
| ## Now go through the aliases. |
| data_frames_checked <- character() |
| for(i in seq_along(aliases)) { |
| ## Store the documented variable names. |
| var_names_in_docs <- sort(Rd_var_names[[i]]) |
| ## Try finding the variable or data set given by the alias. |
| al <- aliases[i] |
| if(!is.null(A <- get0(al, envir = code_env, mode = "list", inherits = FALSE))) |
| al <- A |
| else if(has_namespace && |
| !is.null(A <- get0(al, envir = ns_env, mode = "list", inherits = FALSE))) |
| al <- A |
| else if(has_data) { |
| ## Should be a data set. |
| if(!length(dir(data_dir) |
| %in% paste(al, data_exts, sep = "."))) { |
| next # What the hell did we pick up? |
| } |
| ## Try loading the data set into data_env. |
| utils::data(list = al, envir = data_env) |
| if(!is.null(A <- get0(al, envir = data_env, mode = "list", inherits = FALSE))) |
| al <- A |
| |
| ## And clean up data_env. |
| rm(list = ls(envir = data_env, all.names = TRUE), |
| envir = data_env) |
| } |
| if(!is.data.frame(al)) next |
| ## Now we should be ready: |
| data_frames_checked <- c(data_frames_checked, aliases[i]) |
| var_names_in_code <- sort(names(al)) |
| if(!identical(var_names_in_code, var_names_in_docs)) |
| bad_Rd_objects[[db_names[i]]] <- |
| list(name = aliases[i], |
| code = var_names_in_code, |
| docs = var_names_in_docs) |
| } |
| |
| attr(bad_Rd_objects, "data_frames_checked") <- |
| as.character(data_frames_checked) |
| bad_Rd_objects |
| } |
| |
| format.codocData <- |
| function(x, ...) |
| { |
| format_args <- function(s) paste(s, collapse = " ") |
| |
| .fmt <- function(nm) { |
| docObj <- x[[nm]] |
| ## FIXME singular or plural? |
| c(gettextf("Data codoc mismatches from documentation object '%s':", nm), |
| gettextf("Variables in data frame '%s'", docObj[["name"]]), |
| strwrap(gettextf("Code: %s", format_args(docObj[["code"]])), |
| indent = 2L, exdent = 8L), |
| strwrap(gettextf("Docs: %s", format_args(docObj[["docs"]])), |
| indent = 2L, exdent = 8L), |
| "") |
| } |
| |
| as.character(unlist(lapply(names(x), .fmt))) |
| } |
| |
| ### * checkDocFiles |
| |
| checkDocFiles <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in @code{dir} ... |
| } |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| } |
| |
| db <- if(!missing(package)) |
| Rd_db(package, lib.loc = dirname(dir)) |
| else |
| Rd_db(dir = dir) |
| |
| db_aliases <- lapply(db, .Rd_get_metadata, "alias") |
| db_keywords <- lapply(db, .Rd_get_metadata, "keyword") |
| |
| db_names <- .Rd_get_names_from_Rd_db(db) |
| names(db) <- names(db_aliases) <- db_names |
| |
| db_usages <- lapply(db, .Rd_get_section, "usage") |
| ## We traditionally also use the usage "texts" for some sanity |
| ## checking ... |
| ## <FIXME> |
| ## Remove calling .Rd_drop_comments() eventually. |
| db_usage_texts <- |
| lapply(db_usages, |
| function(e) .Rd_deparse(.Rd_drop_comments(e))) |
| ## </FIXME> |
| db_usages <- lapply(db_usages, .parse_usage_as_much_as_possible) |
| ind <- vapply(db_usages, |
| function(x) !is.null(attr(x, "bad_lines")), |
| NA) |
| bad_lines <- lapply(db_usages[ind], attr, "bad_lines") |
| |
| ## Exclude internal objects from further computations. |
| ind <- (vapply(db_keywords, |
| function(x) match("internal", x, 0L), |
| 0L) > 0L) |
| if(any(ind)) { # exclude them |
| db <- db[!ind] |
| db_names <- db_names[!ind] |
| db_aliases <- db_aliases[!ind] |
| } |
| |
| db_argument_names <- lapply(db, .Rd_get_argument_names) |
| |
| bad_doc_objects <- list() |
| |
| for(docObj in db_names) { |
| |
| exprs <- db_usages[[docObj]] |
| if(!length(exprs)) next |
| |
| aliases <- db_aliases[[docObj]] |
| arg_names_in_arg_list <- db_argument_names[[docObj]] |
| |
| ## Determine function names ('functions') and corresponding |
| ## arguments ('arg_names_in_usage') in the \usage. Note how we |
| ## try to deal with data set documentation. |
| ind <- vapply(exprs, |
| function(e) |
| length(e) > 1L && !is_data_for_dataset(e), |
| NA) |
| exprs <- exprs[ind] |
| ## Split out replacement function usages. |
| ind <- vapply(exprs, .is_call_from_replacement_function_usage, NA) |
| replace_exprs <- exprs[ind] |
| exprs <- exprs[!ind] |
| ## Ordinary functions. |
| functions <- as.character(sapply(exprs, |
| function(e) |
| as.character(e[[1L]]))) |
| ## Catch assignments. |
| ind <- functions %in% c("<-", "=") |
| assignments <- exprs[ind] |
| if(any(ind)) { |
| exprs <- exprs[!ind] |
| functions <- functions[!ind] |
| } |
| ## (Note that as.character(sapply(exprs, "[[", 1L)) does not do |
| ## what we want due to backquotifying.) |
| arg_names_in_usage <- |
| unlist(lapply(exprs, |
| function(e) .arg_names_from_call(e[-1L]))) |
| ## Replacement functions. |
| if(length(replace_exprs)) { |
| replace_funs <- |
| paste0(vapply(replace_exprs, |
| function(e) as.character(e[[2L]][[1L]]), ""), |
| "<-") |
| functions <- c(functions, replace_funs) |
| arg_names_in_usage <- |
| c(arg_names_in_usage, |
| unlist(lapply(replace_exprs, |
| function(e) |
| c(.arg_names_from_call(e[[2L]][-1L]), |
| .arg_names_from_call(e[[3L]]))))) |
| } |
| ## And finally transform the S3 \method{}{} markup into the |
| ## usual function names ... |
| ## <NOTE> |
| ## If we were really picky, we would worry about possible |
| ## namespace renaming. |
| functions <- .transform_S3_method_markup(functions) |
| ## </NOTE> |
| ## Also transform the markup for S4 replacement methods. |
| functions <- .transform_S4_method_markup(functions) |
| |
| ## Now analyze what we found. |
| arg_names_in_usage_missing_in_arg_list <- |
| setdiff(arg_names_in_usage, arg_names_in_arg_list) |
| arg_names_in_arg_list_missing_in_usage <- |
| setdiff(arg_names_in_arg_list, arg_names_in_usage) |
| if(length(arg_names_in_arg_list_missing_in_usage)) { |
| usage_text <- db_usage_texts[[docObj]] |
| bad_args <- character() |
| ## In the case of 'over-documented' arguments, try to be |
| ## defensive and reduce to arguments which either are not |
| ## syntactically valid names or do not match the \usage text |
| ## (modulo word boundaries). |
| bad <- !grepl("^[[:alnum:]._]+$", |
| arg_names_in_arg_list_missing_in_usage) |
| if(any(bad)) { |
| bad_args <- arg_names_in_arg_list_missing_in_usage[bad] |
| arg_names_in_arg_list_missing_in_usage <- |
| arg_names_in_arg_list_missing_in_usage[!bad] |
| } |
| bad <- vapply(arg_names_in_arg_list_missing_in_usage, |
| function(x) |
| !grepl(paste0("(^|\\W)", |
| reQuote(x), |
| "($|\\W)"), |
| gsub("\\\\dots", "...", |
| usage_text)), |
| NA) |
| arg_names_in_arg_list_missing_in_usage <- |
| c(bad_args, |
| arg_names_in_arg_list_missing_in_usage[as.logical(bad)]) |
| ## Note that the fact that we can parse the raw \usage does |
| ## not imply that over-documented arguments are a problem: |
| ## this works for Rd files documenting e.g. shell utilities |
| ## but fails for files with special syntax (Extract.Rd). |
| } |
| |
| ## Also test whether the objects we found from the \usage all |
| ## have aliases, provided that there is no alias which ends in |
| ## '-deprecated' (see e.g. base-deprecated.Rd). |
| if(!any(endsWith(aliases, "-deprecated"))) { |
| ## Argh. There are good reasons for keeping \S4method{}{} |
| ## as is, but of course this is not what the aliases use ... |
| ## <FIXME> |
| ## Should maybe use utils:::topicName(), but in any case, we |
| ## should have functions for converting between the two |
| ## forms, see also the code for undoc(). |
| aliases <- sub("([^,]+),(.+)-method$", |
| "\\\\S4method{\\1}{\\2}", |
| aliases) |
| ## </FIXME> |
| aliases <- gsub("\\\\%", "%", aliases) |
| functions_not_in_aliases <- setdiff(functions, aliases) |
| } |
| else |
| functions_not_in_aliases <- character() |
| |
| if((length(arg_names_in_usage_missing_in_arg_list)) |
| || anyDuplicated(arg_names_in_arg_list) |
| || (length(arg_names_in_arg_list_missing_in_usage)) |
| || (length(functions_not_in_aliases)) |
| || (length(assignments))) |
| bad_doc_objects[[docObj]] <- |
| list(missing = arg_names_in_usage_missing_in_arg_list, |
| duplicated = |
| arg_names_in_arg_list[duplicated(arg_names_in_arg_list)], |
| overdoc = arg_names_in_arg_list_missing_in_usage, |
| unaliased = functions_not_in_aliases, |
| assignments = assignments) |
| |
| } |
| |
| structure(bad_doc_objects, class = "checkDocFiles", |
| "bad_lines" = bad_lines) |
| } |
| |
| format.checkDocFiles <- |
| function(x, ...) |
| { |
| .fmt <- function(nm) { |
| c(character(), |
| if(length(arg_names_in_usage_missing_in_arg_list <- |
| x[[nm]][["missing"]])) { |
| c(gettextf("Undocumented arguments in documentation object '%s'", |
| nm), |
| .pretty_format(unique(arg_names_in_usage_missing_in_arg_list))) |
| }, |
| if(length(duplicated_args_in_arg_list <- |
| x[[nm]][["duplicated"]])) { |
| c(gettextf("Duplicated \\argument entries in documentation object '%s':", |
| nm), |
| .pretty_format(duplicated_args_in_arg_list)) |
| }, |
| if(length(arg_names_in_arg_list_missing_in_usage <- |
| x[[nm]][["overdoc"]])) { |
| c(gettextf("Documented arguments not in \\usage in documentation object '%s':", |
| nm), |
| .pretty_format(unique(arg_names_in_arg_list_missing_in_usage))) |
| }, |
| if(length(functions_not_in_aliases <- |
| x[[nm]][["unaliased"]])) { |
| c(gettextf("Objects in \\usage without \\alias in documentation object '%s':", |
| nm), |
| .pretty_format(unique(functions_not_in_aliases))) |
| }, |
| if(length(assignments <- |
| x[[nm]][["assignments"]])) { |
| c(gettextf("Assignments in \\usage in documentation object '%s':", |
| nm), |
| sprintf(" %s", unlist(lapply(assignments, format)))) |
| }, |
| "") |
| } |
| |
| y <- as.character(unlist(lapply(names(x), .fmt))) |
| |
| if(length(bad_lines <- attr(x, "bad_lines"))) |
| y <- c(y, |
| unlist(lapply(names(bad_lines), |
| function(nm) { |
| c(gettextf("Bad \\usage lines found in documentation object '%s':", |
| nm), |
| paste0(" ", bad_lines[[nm]])) |
| })), |
| "") |
| |
| y |
| } |
| |
| ### * checkDocStyle |
| |
| checkDocStyle <- |
| function(package, dir, lib.loc = NULL) |
| { |
| has_namespace <- FALSE |
| |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in 'dir' ... |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| if(!.haveRds(dir)) |
| stop(gettextf("directory '%s' does not contain Rd objects", dir), |
| domain = NA) |
| package_name <- package |
| is_base <- package_name == "base" |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| |
| objects_in_code <- sort(names(code_env)) |
| |
| ## Does the package have a namespace? |
| ## These days all packages have namespaces, but some are |
| ## auto-generated. |
| if(packageHasNamespace(package, dirname(dir))) { |
| has_namespace <- TRUE |
| ## Determine names of declared S3 methods and associated S3 |
| ## generics. |
| ns_S3_methods_db <- getNamespaceInfo(package, "S3methods") |
| ns_S3_generics <- as.character(ns_S3_methods_db[, 1L]) |
| ns_S3_methods <- ns_S3_methods_db[, 3L] |
| if(!is.character(ns_S3_methods)) { |
| ## As of 2018-07, direct calls to registerS3method() |
| ## could have registered a function object (not name). |
| ind <- vapply(ns_S3_methods, is.character, NA) |
| ns_S3_methods[!ind] <- "" |
| ns_S3_methods <- as.character(ns_S3_methods) |
| } |
| } |
| } |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| package_name <- basename(dir) # early, before resolving sym.links |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| if(!.haveRds(dir)) |
| stop(gettextf("directory '%s' does not contain Rd objects", dir), |
| domain = NA) |
| is_base <- package_name == "base" |
| |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| sys_data_file <- file.path(code_dir, "sysdata.rda") |
| if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) |
| |
| objects_in_code <- sort(names(code_env)) |
| |
| ## Do the package sources have a NAMESPACE file? |
| if(file.exists(file.path(dir, "NAMESPACE"))) { |
| has_namespace <- TRUE |
| nsInfo <- parseNamespaceFile(package_name, dirname(dir)) |
| ## Determine exported objects. |
| OK <- intersect(objects_in_code, nsInfo$exports) |
| for(p in nsInfo$exportPatterns) |
| OK <- c(OK, grep(p, objects_in_code, value = TRUE)) |
| objects_in_code <- unique(OK) |
| ## Determine names of declared S3 methods and associated S3 |
| ## generics. |
| ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo) |
| ns_S3_generics <- ns_S3_methods_db[, 1L] |
| ns_S3_methods <- ns_S3_methods_db[, 3L] |
| } |
| |
| } |
| |
| ## Find the function objects in the given package. |
| functions_in_code <- |
| Filter(function(f) is.function(get(f, envir = code_env)), # get is expensive |
| objects_in_code) |
| |
| ## Find all S3 generics "as seen from the package". |
| all_S3_generics <- |
| unique(c(Filter(function(f) .is_S3_generic(f, envir = code_env), |
| functions_in_code), |
| .get_S3_generics_as_seen_from_package(dir, |
| !missing(package), |
| TRUE), |
| .get_S3_group_generics())) |
| ## <FIXME> |
| ## Not yet: |
| code_env <- .make_S3_group_generic_env(parent = code_env) |
| ## </FIXME> |
| |
| ## Find all methods in the given package for the generic functions |
| ## determined above. Store as a list indexed by the names of the |
| ## generic functions. |
| ## Change in 3.0.0: we only look for methods named generic.class, |
| ## not those registered by a 3-arg S3method(). |
| methods_stop_list <- nonS3methods(package_name) |
| methods_in_package <- sapply(all_S3_generics, function(g) { |
| ## This isn't really right: it assumes the generics are visible. |
| if(!exists(g, envir = code_env)) return(character()) |
| ## <FIXME> |
| ## We should really determine the name g dispatches for, see |
| ## a current version of methods() [2003-07-07]. (Care is needed |
| ## for internal generics and group generics.) |
| name <- paste0(g, ".") |
| methods <- |
| functions_in_code[startsWith(functions_in_code, name)] |
| ## </FIXME> |
| methods <- setdiff(methods, methods_stop_list) |
| if(has_namespace) { |
| ## Find registered methods for generic g. |
| methods2 <- ns_S3_methods[ns_S3_generics == g] |
| ## but for these purposes check name. |
| OK <- startsWith(methods2, name) |
| methods <- c(methods, methods2[OK]) |
| } |
| methods |
| }) |
| all_methods_in_package <- unlist(methods_in_package) |
| ## There are situations where S3 methods might be documented as |
| ## functions (i.e., with their full name), if they do something |
| ## useful also for arguments not inheriting from the class they |
| ## provide a method for. |
| ## But then they should be exported under another name, and |
| ## registered as an S3 method. |
| ## Prior to 2.14.0 we used to allow this in the case the |
| ## package has a namespace and the method is exported (even though |
| ## we strongly prefer using FOO(as.BAR(x)) to FOO.BAR(x) for such |
| ## cases). |
| ## But this caused discontinuities with adding namespaces. |
| ## Historical exception |
| if(package_name == "cluster") |
| all_methods_in_package <- |
| setdiff(all_methods_in_package, functions_in_code) |
| |
| db <- if(!missing(package)) |
| Rd_db(package, lib.loc = dirname(dir)) |
| else |
| Rd_db(dir = dir) |
| |
| names(db) <- db_names <- .Rd_get_names_from_Rd_db(db) |
| |
| ## Ignore pkg-deprecated.Rd and pkg-defunct.Rd. |
| ind <- db_names %in% paste(package_name, c("deprecated", "defunct"), |
| sep = "-") |
| db <- db[!ind] |
| db_names <- db_names[!ind] |
| |
| db_usages <- |
| lapply(db, |
| function(Rd) { |
| Rd <- .Rd_get_section(Rd, "usage") |
| .parse_usage_as_much_as_possible(Rd) |
| }) |
| ind <- vapply(db_usages, |
| function(x) !is.null(attr(x, "bad_lines")), |
| NA) |
| bad_lines <- lapply(db_usages[ind], attr, "bad_lines") |
| |
| bad_doc_objects <- list() |
| |
| for(docObj in db_names) { |
| |
| ## Determine function names in the \usage. |
| exprs <- db_usages[[docObj]] |
| exprs <- exprs[lengths(exprs) > 1L] |
| ## Ordinary functions. |
| functions <- |
| as.character(sapply(exprs, |
| function(e) as.character(e[[1L]]))) |
| ## (Note that as.character(sapply(exprs, "[[", 1L)) does not do |
| ## what we want due to backquotifying.) |
| ## Replacement functions. |
| ind <- vapply(exprs, .is_call_from_replacement_function_usage, NA) |
| if(any(ind)) { |
| replace_funs <- |
| paste0(sapply(exprs[ind], |
| function(e) as.character(e[[2L]][[1L]])), |
| "<-") |
| functions <- c(functions, replace_funs) |
| } |
| |
| methods_with_full_name <- |
| intersect(functions, all_methods_in_package) |
| |
| functions <- .transform_S3_method_markup(functions) |
| |
| methods_with_generic <- |
| sapply(intersect(functions, all_S3_generics), |
| function(g) |
| intersect(functions, methods_in_package[[g]]), |
| simplify = FALSE) |
| |
| if((length(methods_with_generic)) || |
| (length(methods_with_full_name))) |
| bad_doc_objects[[docObj]] <- |
| list(withGeneric = methods_with_generic, |
| withFullName = methods_with_full_name) |
| |
| } |
| |
| attr(bad_doc_objects, "bad_lines") <- bad_lines |
| class(bad_doc_objects) <- "checkDocStyle" |
| bad_doc_objects |
| } |
| |
| format.checkDocStyle <- |
| function(x, ...) |
| { |
| .fmt <- function(nm) { |
| ## <NOTE> |
| ## With \method{GENERIC}{CLASS} now being transformed to show |
| ## both GENERIC and CLASS info, documenting S3 methods on the |
| ## same page as their generic is not necessarily a problem any |
| ## more (as one can refer to the generic or the methods in the |
| ## documentation, in particular for the primary argument). |
| ## Hence, even if we still provide information about this, we |
| ## no longer print it by default. One can still access it via |
| ## lapply(checkDocStyle("foo"), "[[", "withGeneric") |
| ## (but of course it does not print that nicely anymore), |
| ## </NOTE> |
| methods_with_full_name <- x[[nm]][["withFullName"]] |
| if(length(methods_with_full_name)) { |
| c(gettextf("S3 methods shown with full name in documentation object '%s':", |
| nm), |
| .pretty_format(methods_with_full_name), |
| "") |
| } else { |
| character() |
| } |
| } |
| |
| as.character(unlist(lapply(names(x), .fmt))) |
| } |
| |
| |
| ### * checkFF |
| |
| checkFF <- |
| function(package, dir, file, lib.loc = NULL, |
| registration = FALSE, check_DUP = FALSE, |
| verbose = getOption("verbose")) |
| { |
| allow_suppress <- !nzchar(Sys.getenv("_R_CHECK_FF_AS_CRAN_")) |
| suppressCheck <- function(e) |
| allow_suppress && |
| length(e) == 2L && is.call(e) && is.symbol(e[[1L]]) && |
| as.character(e[[1L]]) == "dontCheck" |
| |
| has_namespace <- FALSE |
| is_installed_msg <- is_installed <- FALSE |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| dfile <- file.path(dir, "DESCRIPTION") |
| db <- .read_description(dfile) |
| pkg <- pkgDLL <- basename(dir) |
| ## Using package installed in @code{dir} ... |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| have_registration <- FALSE |
| if(basename(dir) != "base") { |
| .load_package_quietly(package, lib.loc) |
| code_env <- asNamespace(package) |
| if(!is.null(DLLs <- get0("DLLs", envir = code_env$.__NAMESPACE__.))) { |
| ## fake installs have this, of class DLLInfoList |
| if(length(DLLs)) has_namespace <- TRUE |
| if(length(DLLs) && inherits(DLLs[[1L]], "DLLInfo")) { |
| pkgDLL <- unclass(DLLs[[1L]])$name # different for data.table |
| if(registration) { |
| reg <- getDLLRegisteredRoutines(DLLs[[1L]]) |
| have_registration <- sum(lengths(reg)) > 0L |
| } |
| } |
| } |
| } else { |
| has_namespace <- have_registration <- TRUE |
| code_env <-.package_env(package) |
| } |
| is_installed <- TRUE |
| } |
| else if(!missing(dir)) { |
| have_registration <- FALSE |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| pkg <- pkgDLL <- basename(dir) |
| dfile <- file.path(dir, "DESCRIPTION") |
| enc <- NA; db <- NULL |
| if(file.exists(dfile)) { |
| db <- .read_description(dfile) |
| enc <- db["Encoding"] |
| } |
| if(pkg == "base") has_namespace <- TRUE |
| if(file.exists(file.path(dir, "NAMESPACE"))) { |
| nm <- parseNamespaceFile(basename(dir), dirname(dir)) |
| has_namespace <- length(nm$dynlibs) > 0L |
| } |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| file <- tempfile() |
| on.exit(unlink(file)) |
| if(!file.create(file)) stop("unable to create ", file, domain = NA) |
| if(!all(.file_append_ensuring_LFs(file, |
| list_files_with_type(code_dir, |
| "code")))) |
| stop("unable to write code files", domain = NA) |
| } |
| else if(!missing(file)) { |
| pkg <- enc <- NA |
| } else |
| stop("you must specify 'package', 'dir' or 'file'") |
| |
| if(missing(package) && !file_test("-f", file)) |
| stop(gettextf("file '%s' does not exist", file), |
| domain = NA) |
| |
| ## Should there really be a 'verbose' argument? |
| ## It may be useful to extract all foreign function calls but then |
| ## we would want the calls back ... |
| ## What we currently do is the following: if 'verbose' is true, we |
| ## show all foreign function calls in abbreviated form with the line |
| ## ending in either 'OK' or 'MISSING', and we return the list of |
| ## 'bad' FF calls (i.e., where the 'PACKAGE' argument is missing) |
| ## *invisibly* (so that output is not duplicated). |
| ## Otherwise, if not verbose, we return the list of bad FF calls. |
| |
| bad_exprs <- empty_exprs <- wrong_pkg <- other_problem <- list() |
| other_desc <- character() |
| bad_pkg <- character() |
| dup_false <- list() |
| FF_funs <- FF_fun_names <- c(".C", ".Fortran", ".Call", ".External", |
| ".Call.graphics", ".External.graphics") |
| ## As pointed out by DTL, packages could use non-base FF calls for |
| ## which missing 'PACKAGE' arguments are not necessarily a problem. |
| if(!missing(package)) { |
| is_FF_fun_from_base <- |
| vapply(FF_funs, |
| function(f) { |
| e <- .find_owner_env(f, code_env) |
| (identical(e, baseenv()) |
| || identical(e, .BaseNamespaceEnv)) |
| }, |
| NA) |
| FF_funs <- FF_funs[is_FF_fun_from_base] |
| } |
| ## Also, need to handle base::.Call() etc ... |
| FF_funs <- c(FF_funs, sprintf("base::%s", FF_fun_names)) |
| |
| check_registration <- function(e, fr) { |
| sym <- e[[2L]] |
| name <- deparse(sym, nlines = 1L) |
| if (name == "...") |
| return ("SYMBOL OK") # we cannot check this, e.g. RProtoBuf |
| |
| if (is.character(sym)) { |
| if (!have_registration) return ("SYMBOL OK") |
| FF_fun <- as.character(e[[1L]]) |
| sym <- reg[[FF_fun]][[sym]] |
| if(is.null(sym)) return ("SYMBOL OK") |
| } |
| |
| if (!is_installed) { |
| if (!is_installed_msg) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- c(other_desc, "foreign function registration not tested, as package was not installed") |
| is_installed_msg <<- TRUE |
| } |
| return("OTHER") # registration checks need the package to be installed |
| } |
| if (is.symbol(sym)) { # it might be something like pkg::sym (that's a call) |
| if (!exists(name, code_env, inherits = FALSE)) { |
| if (allow_suppress && |
| name %in% utils::suppressForeignCheck(, package)) |
| return ("SYMBOL OK") # skip false positives |
| if (have_registration) { |
| if (name %in% fr) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- |
| c(other_desc, |
| sprintf("symbol %s in the local frame", |
| sQuote(name))) |
| } else { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- |
| c(other_desc, |
| sprintf("symbol %s not in namespace", |
| sQuote(name))) |
| } |
| } |
| return("OTHER") |
| } |
| } else if (suppressCheck(sym)) |
| return("SKIPPED") |
| |
| sym <- tryCatch(eval(sym, code_env), error = function(e) e) |
| if (inherits(sym, "error")) { |
| if (have_registration || !allow_suppress) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- |
| c(other_desc, sprintf("Evaluating %s during check gives error\n%s", |
| sQuote(name), sQuote(sym$message))) |
| } |
| return("OTHER") |
| } |
| |
| FF_fun <- as.character(e[[1L]]) |
| ## lmom's sym evaluate to character, so try to look up. |
| ## FIXME: maybe check this is not PACKAGE = "another package" |
| if (is.character(sym)) { |
| if (!have_registration) return ("SYMBOL OK") |
| sym <- reg[[FF_fun]][[sym]] |
| if(is.null(sym)) return ("SYMBOL OK") |
| } |
| |
| ## These are allowed and used by SU's packages so skip for now |
| if (inherits(sym, "RegisteredNativeSymbol") |
| || inherits(sym, "NativeSymbol")) |
| return ("SYMBOL OK") |
| |
| if (!inherits(sym, "NativeSymbolInfo")) { |
| other_problem <<- c(other_problem, e) |
| ## other_desc <<- c(other_desc, sprintf("\"%s\" is not of class \"%s\"", name, "NativeSymbolInfo")) |
| other_desc <<- c(other_desc, sprintf("%s is of class \"%s\"", |
| sQuote(name), class(sym))) |
| return("OTHER") |
| } |
| ## This might be symbol from another (base?) package. |
| ## Allow for Rcpp modules |
| parg <- unclass(sym$dll)$name |
| if(length(parg) == 1L && parg %notin% c("Rcpp", pkgDLL)) { |
| wrong_pkg <<- c(wrong_pkg, e) |
| bad_pkg <<- c(bad_pkg, parg) |
| } |
| numparms <- sym$numParameters |
| if (length(numparms) && numparms >= 0) { |
| ## We have to be careful if ... is in the call. |
| if (any(as.character(e) == "...")) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- |
| c(other_desc, |
| sprintf("call includes ..., expected %d %s", |
| numparms, |
| if(numparms > 1L) "parameters" else "parameter")) |
| } else { |
| callparms <- length(e) - 2L |
| if ("PACKAGE" %in% names(e)) callparms <- callparms - 1L |
| if (FF_fun %in% c(".C", ".Fortran")) |
| callparms <- callparms - length(intersect(names(e), c("NAOK", "DUP", "ENCODING"))) |
| if (!is.null(numparms) && numparms >= 0L && numparms != callparms) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- |
| c(other_desc, |
| sprintf("call to %s with %d %s, expected %d", |
| sQuote(name), callparms, |
| if(callparms > 1L) "parameters" else "parameter", |
| numparms)) |
| return("OTHER") |
| } |
| } |
| } |
| if (inherits(sym, "CallRoutine") && |
| (FF_fun %notin% c(".Call", ".Call.graphics"))) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- c(other_desc, sprintf("%s registered as %s, but called with %s", sQuote(name), ".Call", FF_fun)) |
| return("OTHER") |
| } |
| if (inherits(sym, "ExternalRoutine") && !(FF_fun %in% c(".External", ".External.graphics"))) { |
| other_problem <<- c(other_problem, e) |
| other_desc <<- c(other_desc, sprintf("%s registered as %s, but called with %s", sQuote(name), ".External", FF_fun)) |
| return("OTHER") |
| } |
| |
| "SYMBOL OK" |
| } |
| |
| find_bad_exprs <- function(e) { |
| if(is.call(e) || is.expression(e)) { |
| ## <NOTE> |
| ## This picks up all calls, e.g. a$b, and they may convert |
| ## to a vector. The function is the first element in all |
| ## the calls we are interested in. |
| ## BDR 2002-11-28 |
| ## </NOTE> |
| if(deparse(e[[1L]])[1L] %in% FF_funs) { |
| if(registration) check_registration(e, fr) |
| dup <- e[["DUP"]] |
| if(!is.null(dup) && !isTRUE(dup)) |
| dup_false <<- c(dup_false, e) |
| this <- "" |
| this <- parg <- e[["PACKAGE"]] |
| if (!is.na(pkg) && is.character(parg) && |
| nzchar(parg) && parg != pkgDLL) { |
| wrong_pkg <<- c(wrong_pkg, e) |
| bad_pkg <<- c(bad_pkg, this) |
| } |
| parg <- if(!is.null(parg) && (nzchar(parg))) "OK" |
| else if(identical(parg, "")) { |
| empty_exprs <<- c(empty_exprs, e) |
| "EMPTY" |
| } else if(!is.character(sym <- e[[2L]])) { |
| if (!registration) { |
| sym <- tryCatch(eval(sym, code_env), |
| error = function(e) e) |
| if (inherits(sym, "NativeSymbolInfo")) { |
| ## This might be symbol from another package. |
| ## Allow for Rcpp modules |
| parg <- unclass(sym$dll)$name |
| if(length(parg) == 1L && |
| parg %notin% c("Rcpp", pkgDLL)) { |
| wrong_pkg <<- c(wrong_pkg, e) |
| bad_pkg <<- c(bad_pkg, parg) |
| } |
| } |
| } |
| "Called with symbol" |
| } else if(!has_namespace) { |
| bad_exprs <<- c(bad_exprs, e) |
| "MISSING" |
| } else "MISSING but in a function in a namespace" |
| if(verbose) |
| if(is.null(this)) |
| cat(deparse(e[[1L]]), "(", deparse(e[[2L]]), |
| ", ... ): ", parg, "\n", sep = "") |
| else |
| cat(deparse(e[[1L]]), "(", deparse(e[[2L]]), |
| ", ..., PACKAGE = \"", this, "\"): ", |
| parg, "\n", sep = "") |
| } else if (deparse(e[[1L]])[1L] %in% "<-") { |
| fr <<- c(fr, as.character(e[[2L]])) |
| } |
| for(i in seq_along(e)) Recall(e[[i]]) |
| } |
| } |
| |
| if(!missing(package)) { |
| checkFFmy <- function(f) |
| if(typeof(f) == "closure") { |
| env <- environment(f) |
| if(isNamespace(env)) { |
| nm <- getNamespaceName(env) |
| if (nm == package) body(f) else NULL |
| } else body(f) |
| } else NULL |
| exprs <- lapply(ls(envir = code_env, all.names = TRUE), |
| function(f) { |
| f <- get(f, envir = code_env) # get is expensive |
| checkFFmy(f) |
| }) |
| if(.isMethodsDispatchOn()) { |
| ## Also check the code in S4 methods. |
| ## This may find things twice if a setMethod() with a bad FF |
| ## call is from inside a function (e.g., InitMethods()). |
| for(f in .get_S4_generics(code_env)) { |
| mlist <- .get_S4_methods_list(f, code_env) |
| exprs <- c(exprs, lapply(mlist, body)) |
| } |
| refs <- .get_ref_classes(code_env) |
| if(length(refs)) { |
| exprs2 <- lapply(unlist(refs, FALSE), checkFFmy) |
| exprs <- c(exprs, exprs2) |
| } |
| } |
| } else { |
| if(!is.na(enc) && |
| (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { |
| ## FIXME: what if conversion fails on e.g. UTF-8 comments |
| con <- file(file, encoding=enc) |
| on.exit(close(con)) |
| } else con <- file |
| exprs <- |
| tryCatch(parse(file = con, n = -1L), |
| error = function(e) |
| stop(gettextf("parse error in file '%s':\n%s", |
| file, |
| .massage_file_parse_error_message(conditionMessage(e))), |
| domain = NA, call. = FALSE)) |
| } |
| for(i in seq_along(exprs)) { |
| fr <- character() |
| find_bad_exprs(exprs[[i]]) |
| } |
| attr(bad_exprs, "wrong_pkg") <- wrong_pkg |
| attr(bad_exprs, "bad_pkg") <- bad_pkg |
| attr(bad_exprs, "empty") <- empty_exprs |
| attr(bad_exprs, "other_problem") <- other_problem |
| attr(bad_exprs, "other_desc") <- other_desc |
| if(check_DUP) attr(bad_exprs, "dup_false") <- dup_false |
| if (length(bad_pkg)) { # check against dependencies. |
| bases <- .get_standard_package_names()$base |
| bad <- bad_pkg %w/o% bases |
| if (length(bad)) { |
| depends <- .get_requires_from_package_db(db, "Depends") |
| imports <- .get_requires_from_package_db(db, "Imports") |
| suggests <- .get_requires_from_package_db(db, "Suggests") |
| enhances <- .get_requires_from_package_db(db, "Enhances") |
| bad <- bad %w/o% c(depends, imports, suggests, enhances) |
| attr(bad_exprs, "undeclared") <- bad |
| } |
| } |
| class(bad_exprs) <- "checkFF" |
| if(verbose) |
| invisible(bad_exprs) |
| else |
| bad_exprs |
| } |
| |
| format.checkFF <- |
| function(x, ...) |
| { |
| xx <- attr(x, "empty") |
| y <- attr(x, "wrong_pkg") |
| z <- attr(x, "bad_pkg") |
| zz <- attr(x, "undeclared") |
| other_problem <- attr(x, "other_problem") |
| |
| res <- character() |
| if (length(x)) { |
| .fmt <- function(x) |
| paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)") |
| msg <- ngettext(length(x), |
| "Foreign function call without 'PACKAGE' argument:", |
| "Foreign function calls without 'PACKAGE' argument:", |
| domain = NA) |
| res <- c(msg, unlist(lapply(x, .fmt))) |
| } |
| if (length(xx)) { |
| .fmt <- function(x) |
| paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)") |
| msg <- ngettext(length(x), |
| "Foreign function call with empty 'PACKAGE' argument:", |
| "Foreign function calls with empty 'PACKAGE' argument:", |
| domain = NA) |
| res <- c(res, msg, unlist(lapply(xx, .fmt))) |
| } |
| |
| if (length(y)) { |
| bases <- .get_standard_package_names()$base |
| .fmt2 <- function(x, z) { |
| if("PACKAGE" %in% names(x)) |
| paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), |
| ", ..., PACKAGE = \"", z, "\")") |
| else |
| paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)") |
| } |
| base <- z %in% bases |
| if(any(base)) { |
| xx <- unlist(lapply(seq_along(y)[base], |
| function(i) .fmt2(y[[i]], z[i]))) |
| xx <- unique(xx) |
| msg <- ngettext(length(xx), |
| "Foreign function call to a base package:", |
| "Foreign function calls to a base package:", |
| domain = NA) |
| res <- c(res, msg, sort(xx)) |
| } |
| if(any(!base)) { |
| xx <- unlist(lapply(seq_along(y)[!base], |
| function(i) .fmt2(y[[i]], z[i]))) |
| xx <- unique(xx) |
| msg <- ngettext(length(xx), |
| "Foreign function call to a different package:", |
| "Foreign function calls to a different package:", |
| domain = NA) |
| res <- c(res, msg, sort(xx)) |
| } |
| } |
| if (length(zz)) { |
| zz <- unique(zz) |
| msg <- ngettext(length(zz), |
| "Undeclared package in foreign function calls:", |
| "Undeclared packages in foreign function calls:", |
| domain = NA) |
| res <- c(res, msg, paste(" ", paste(sQuote(sort(zz)), collapse = ", "))) |
| } |
| if (length(other_problem)) { |
| msg <- ngettext(length(other_problem), |
| "Registration problem:", |
| "Registration problems:", |
| domain = NA) |
| res <- c(res, msg) |
| other_desc <- attr(x, "other_desc") |
| for (i in seq_along(other_problem)) { |
| res <- c(res, paste0(" ", other_desc[i], ":"), |
| paste0(" ", deparse(other_problem[[i]]))) |
| } |
| } |
| z3 <- attr(x, "dup_false") |
| if (length(z3)) { |
| msg <- ngettext(length(z3), |
| "Call with DUP:", |
| "Calls with DUP:", |
| domain = NA) |
| res <- c(res, msg) |
| for (i in seq_along(z3)) { |
| res <- c(res, paste0(" ", deparse(z3[[i]]))) |
| } |
| } |
| res |
| } |
| |
| ### * checkS3methods |
| |
| checkS3methods <- |
| function(package, dir, lib.loc = NULL) |
| { |
| has_namespace <- FALSE |
| ## If an installed package has a namespace, we need to record the S3 |
| ## methods which are registered but not exported (so that we can |
| ## get() them from the right place). |
| S3_reg <- character() |
| |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in @code{dir} ... |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| is_base <- basename(dir) == "base" |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| |
| objects_in_code <- sort(names(code_env)) |
| |
| ## Does the package have a namespace? |
| if(packageHasNamespace(package, dirname(dir))) { |
| has_namespace <- TRUE |
| ## Determine names of declared S3 methods and associated S3 |
| ## generics. |
| ns_S3_methods_db <- getNamespaceInfo(package, "S3methods") |
| ns_S3_generics <- as.character(ns_S3_methods_db[, 1L]) |
| ## We really need the GENERIC.CLASS method names used in the |
| ## registry: |
| ns_S3_methods <- |
| paste(ns_S3_generics, |
| as.character(ns_S3_methods_db[, 2L]), |
| sep = ".") |
| ## Determine unexported but declared S3 methods. |
| S3_reg <- setdiff(ns_S3_methods, objects_in_code) |
| } |
| } |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| is_base <- basename(dir) == "base" |
| |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| sys_data_file <- file.path(code_dir, "sysdata.rda") |
| if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) |
| |
| objects_in_code <- sort(names(code_env)) |
| |
| ## Does the package have a NAMESPACE file? |
| if(file.exists(file.path(dir, "NAMESPACE"))) { |
| has_namespace <- TRUE |
| nsInfo <- parseNamespaceFile(basename(dir), dirname(dir)) |
| ## Determine exported objects. |
| OK <- intersect(objects_in_code, nsInfo$exports) |
| for(p in nsInfo$exportPatterns) |
| OK <- c(OK, grep(p, objects_in_code, value = TRUE)) |
| objects_in_code <- unique(OK) |
| ## Determine names of declared S3 methods and associated S3 |
| ## generics. |
| ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo) |
| ns_S3_generics <- ns_S3_methods_db[, 1L] |
| ns_S3_methods <- ns_S3_methods_db[, 3L] |
| } |
| |
| } |
| |
| ## Find the function objects in the given package. |
| functions_in_code <- |
| Filter(function(f) is.function(code_env[[f]]), |
| objects_in_code) |
| |
| ## This is the virtual group generics, not the members |
| S3_group_generics <- .get_S3_group_generics() |
| ## This includes the primitive group generics as from R 2.6.0 |
| S3_primitive_generics <- .get_S3_primitive_generics() |
| |
| checkArgs <- function(g, m) { |
| ## Do the arguments of method m (in code_env) 'extend' those of |
| ## the generic g as seen from code_env? The method must have all |
| ## arguments the generic has, with positional arguments of g in |
| ## the same positions for m. |
| ## Exception: '...' in the method swallows anything. |
| if(identical(g, "round") && m == "round.POSIXt") return() # exception |
| genfun <- get(g, envir = code_env) |
| gArgs <- names(formals(genfun)) |
| if(identical(g, "plot")) gArgs <- gArgs[-2L] # drop "y" |
| ogArgs <- gArgs |
| gm <- if(m %in% S3_reg) { |
| ## See registerS3method() in ../../base/R/namespace.R. |
| defenv <- |
| if (g %in% S3_group_generics || g %in% S3_primitive_generics) |
| .BaseNamespaceEnv |
| else { |
| if(.isMethodsDispatchOn() |
| && methods::is(genfun, "genericFunction")) |
| genfun <- methods::finalDefaultMethod(genfun@default) |
| if (typeof(genfun) == "closure") environment(genfun) |
| else .BaseNamespaceEnv |
| } |
| if(is.null(S3Table <- get0(".__S3MethodsTable__.", envir = defenv, |
| inherits = FALSE))) { |
| ## Happens e.g. if for some reason, we get "plot" as |
| ## standardGeneric for "plot" defined from package |
| ## "graphics" with its own environment which does not |
| ## contain an S3 methods table ... |
| return(NULL) |
| } |
| if(is.null(mm <- get0(m, envir = S3Table))) { |
| warning(gettextf("declared S3 method '%s' not found", m), |
| domain = NA, call. = FALSE) |
| return(NULL) |
| } else mm |
| } else get(m, envir = code_env) |
| mArgs <- omArgs <- names(formals(gm)) |
| ## If m is a formula method, its first argument *may* be called |
| ## formula. (Note that any argument name mismatch throws an |
| ## error in current S-PLUS versions.) |
| if(endsWith(m, ".formula")) { |
| if(gArgs[1L] != "...") gArgs <- gArgs[-1L] |
| mArgs <- mArgs[-1L] |
| } |
| dotsPos <- which(gArgs == "...") |
| ipos <- if(length(dotsPos)) |
| seq_len(dotsPos[1L] - 1L) |
| else |
| seq_along(gArgs) |
| |
| ## careful, this could match multiply in incorrect funs. |
| dotsPos <- which(mArgs == "...") |
| if(length(dotsPos)) |
| ipos <- ipos[seq_len(dotsPos[1L] - 1L)] |
| posMatchOK <- identical(gArgs[ipos], mArgs[ipos]) |
| argMatchOK <- all(gArgs %in% mArgs) || length(dotsPos) > 0L |
| margMatchOK <- all(mArgs %in% c("...", gArgs)) || "..." %in% ogArgs |
| if(posMatchOK && argMatchOK && margMatchOK) |
| NULL |
| else if (g %in% c("+", "-", "*", "/", "^", "%%", "%/%", "&", "|", |
| "!", "==", "!=", "<", "<=", ">=", ">") |
| && (length(ogArgs) == length(omArgs)) ) |
| NULL |
| else { |
| l <- list(ogArgs, omArgs) |
| names(l) <- c(g, m) |
| list(l) |
| } |
| } |
| |
| all_S3_generics <- |
| unique(c(Filter(function(f) .is_S3_generic(f, envir = code_env), |
| functions_in_code), |
| .get_S3_generics_as_seen_from_package(dir, |
| !missing(package), |
| TRUE), |
| ## This had 'FALSE' for a long time, in which case we |
| ## miss the primitive generics regarded as language |
| ## elements. |
| S3_group_generics, S3_primitive_generics)) |
| ## <FIXME> |
| ## Not yet: |
| code_env <- .make_S3_group_generic_env(parent = code_env) |
| ## </FIXME> |
| code_env <- .make_S3_primitive_generic_env(parent = code_env) |
| |
| ## Now determine the 'bad' methods in the function objects of the |
| ## package. |
| bad_methods <- list() |
| methods_stop_list <- nonS3methods(basename(dir)) |
| ## some packages export S4 generics derived from other packages .... |
| methods_stop_list <- |
| c(methods_stop_list, |
| "all.equal", "all.names", "all.vars", "fitted.values", "qr.Q", |
| "qr.R", "qr.X", "qr.coef", "qr.fitted", "qr.qty", "qr.qy", |
| "qr.resid", "qr.solve", "rep.int", "seq.int", "sort.int", |
| "sort.list", "t.test") |
| methods_not_registered_but_exported <- character() |
| ## <FIXME> |
| ## Seems we currently cannot get these, because we only look at |
| ## *exported* functions in addition to the S3 registry. |
| methods_not_registered_not_exported <- character() |
| ## </FIXME> |
| for(g in all_S3_generics) { |
| if(!exists(g, envir = code_env)) next |
| ## Find all methods in functions_in_code for S3 generic g. |
| ## <FIXME> |
| ## We should really determine the name g dispatches for, see |
| ## a current version of methods() [2003-07-07]. (Care is |
| ## needed for internal generics and group generics.) |
| name <- paste0(g, ".") |
| methods <- |
| functions_in_code[startsWith(functions_in_code, name)] |
| ## </FIXME> |
| methods <- setdiff(methods, methods_stop_list) |
| if(has_namespace) { |
| ## Find registered methods for generic g. |
| methods <- c(methods, ns_S3_methods[ns_S3_generics == g]) |
| if(length(delta <- setdiff(methods, ns_S3_methods))) { |
| methods_not_registered_but_exported <- |
| c(methods_not_registered_but_exported, |
| intersect(delta, objects_in_code)) |
| methods_not_registered_not_exported <- |
| c(methods_not_registered_not_exported, |
| setdiff(delta, objects_in_code)) |
| } |
| } |
| |
| if(any(g == langElts)) next |
| |
| for(m in methods) |
| ## Both all() and all.equal() are generic. |
| bad_methods <- if(g == "all") { |
| m1 <- m[!startsWith(m, "all.equal")] |
| c(bad_methods, if(length(m1)) checkArgs(g, m1)) |
| } else c(bad_methods, checkArgs(g, m)) |
| } |
| |
| if(length(methods_not_registered_but_exported)) |
| attr(bad_methods, "methods_not_registered_but_exported") <- |
| methods_not_registered_but_exported |
| if(length(methods_not_registered_not_exported)) |
| attr(bad_methods, "methods_not_registered_not_exported") <- |
| methods_not_registered_not_exported |
| |
| class(bad_methods) <- "checkS3methods" |
| bad_methods |
| } |
| |
| format.checkS3methods <- |
| function(x, ...) |
| { |
| format_args <- function(s) |
| paste0("function(", paste(s, collapse = ", "), ")") |
| |
| .fmt <- function(entry) { |
| c(paste0(names(entry)[1L], ":"), |
| strwrap(format_args(entry[[1L]]), indent = 2L, exdent = 11L), |
| paste0(names(entry)[2L], ":"), |
| strwrap(format_args(entry[[2L]]), indent = 2L, exdent = 11L), |
| "") |
| } |
| |
| report_S3_methods_not_registered <- |
| config_val_to_logical(Sys.getenv("_R_CHECK_S3_METHODS_NOT_REGISTERED_", |
| "TRUE")) |
| |
| c(as.character(unlist(lapply(x, .fmt))), |
| if(report_S3_methods_not_registered && |
| length(methods <- attr(x, "methods_not_registered_but_exported"))) { |
| c("Found the following apparent S3 methods exported but not registered:", |
| strwrap(paste(sort(methods), collapse = " "), |
| exdent = 2L, indent = 2L)) |
| } |
| ) |
| } |
| |
| ### * checkReplaceFuns |
| |
| checkReplaceFuns <- |
| function(package, dir, lib.loc = NULL) |
| { |
| has_namespace <- FALSE |
| |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in @code{dir} ... |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| is_base <- basename(dir) == "base" |
| |
| ## Load package into code_env. |
| if(!is_base) |
| .load_package_quietly(package, lib.loc) |
| ## In case the package has a namespace, we really want to check |
| ## all replacement functions in the package. (If not, we need |
| ## to change the code for the non-installed case to only look at |
| ## exported (replacement) functions.) |
| if(packageHasNamespace(package, dirname(dir))) { |
| has_namespace <- TRUE |
| code_env <- asNamespace(package) |
| ns_S3_methods_db <- .getNamespaceInfo(code_env, "S3methods") |
| } |
| else |
| code_env <- .package_env(package) |
| } |
| |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| is_base <- basename(dir) == "base" |
| |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| sys_data_file <- file.path(code_dir, "sysdata.rda") |
| if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) |
| |
| ## Does the package have a NAMESPACE file? Note that when |
| ## working on the sources we (currently?) cannot deal with the |
| ## (experimental) alternative way of specifying the namespace. |
| if(file.exists(file.path(dir, "NAMESPACE"))) { |
| has_namespace <- TRUE |
| nsInfo <- parseNamespaceFile(basename(dir), dirname(dir)) |
| ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo) |
| } |
| } |
| |
| objects_in_code <- sort(names(code_env)) |
| replace_funs <- character() |
| |
| if(has_namespace) { |
| ns_S3_generics <- as.character(ns_S3_methods_db[, 1L]) |
| ns_S3_methods <- ns_S3_methods_db[, 3L] |
| if(!is.character(ns_S3_methods)) { |
| ## As of 2018-07, direct calls to registerS3method() |
| ## could have registered a function object (not name). |
| ind <- vapply(ns_S3_methods, is.character, NA) |
| ns_S3_methods[!ind] <- "" |
| ns_S3_methods <- as.character(ns_S3_methods) |
| } |
| ## S3 replacement methods from namespace registration? |
| replace_funs <- ns_S3_methods[endsWith(ns_S3_generics, "<-")] |
| ## Now remove the functions registered as S3 methods. |
| objects_in_code <- setdiff(objects_in_code, ns_S3_methods) |
| } |
| |
| replace_funs <- |
| c(replace_funs, grep("<-", objects_in_code, value = TRUE)) |
| ## Drop %xxx% binops. |
| ## Spotted by Hugh Parsonage <hugh.parsonage@gmail.com>. |
| replace_funs <- |
| replace_funs[!(startsWith(replace_funs, "%") & |
| endsWith(replace_funs, "%"))] |
| |
| .check_last_formal_arg <- function(f) { |
| arg_names <- names(formals(f)) |
| if(!length(arg_names)) |
| TRUE # most likely a .Primitive() |
| else |
| identical(arg_names[length(arg_names)], "value") |
| } |
| |
| ## Find the replacement functions (which have formal arguments) with |
| ## last arg not named 'value'. |
| bad_replace_funs <- if(length(replace_funs)) { |
| Filter(function(f) { |
| ## Always get the functions from code_env ... |
| ## Should maybe get S3 methods from the registry ... |
| f <- get(f, envir = code_env) # get is expensive |
| if(!is.function(f)) return(FALSE) |
| ! .check_last_formal_arg(f) |
| }, |
| replace_funs) |
| } else character() |
| |
| if(.isMethodsDispatchOn()) { |
| S4_generics <- .get_S4_generics(code_env) |
| ## Assume that the ones with names ending in '<-' are always |
| ## replacement functions. |
| S4_generics <- S4_generics[endsWith(names(S4_generics), "<-")] |
| bad_S4_replace_methods <- |
| sapply(S4_generics, |
| function(f) { |
| mlist <- .get_S4_methods_list(f, code_env) |
| ind <- !vapply(mlist, .check_last_formal_arg, NA) |
| if(!any(ind)) |
| character() |
| else { |
| sigs <- .make_siglist(mlist[ind]) |
| sprintf("\\S4method{%s}{%s}", f, sigs) |
| } |
| }) |
| bad_replace_funs <- |
| c(bad_replace_funs, |
| unlist(bad_S4_replace_methods, use.names = FALSE)) |
| } |
| |
| class(bad_replace_funs) <- "checkReplaceFuns" |
| bad_replace_funs |
| } |
| |
| format.checkReplaceFuns <- |
| function(x, ...) |
| { |
| if(length(x)) |
| .pretty_format(unclass(x)) |
| else |
| character() |
| } |
| |
| ### * checkTnF |
| |
| checkTnF <- |
| function(package, dir, file, lib.loc = NULL) |
| { |
| code_files <- docs_files <- character() |
| |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| ## Using package installed in @code{dir} ... |
| dir <- find.package(package, lib.loc) |
| if(file.exists(file.path(dir, "R", "all.rda"))) { |
| warning("cannot check R code installed as image") |
| } |
| code_file <- file.path(dir, "R", package) |
| if(file.exists(code_file)) # could be data-only |
| code_files <- code_file |
| example_dir <- file.path(dir, "R-ex") |
| if(dir.exists(example_dir)) { |
| code_files <- c(code_files, |
| list_files_with_exts(example_dir, "R")) |
| } |
| } |
| else if(!missing(dir)) { |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(dir.exists(code_dir)) # could be data-only |
| code_files <- list_files_with_type(code_dir, "code") |
| docs_dir <- file.path(dir, "man") |
| if(dir.exists(docs_dir)) |
| docs_files <- list_files_with_type(docs_dir, "docs") |
| } |
| else if(!missing(file)) { |
| if(!file_test("-f", file)) |
| stop(gettextf("file '%s' does not exist", file), |
| domain = NA) |
| else |
| code_files <- file |
| } |
| else |
| stop("you must specify 'package', 'dir' or 'file'") |
| |
| find_TnF_in_code <- function(file, txt) { |
| ## If 'txt' is given, it contains the extracted examples from |
| ## the R documentation file 'file'. Otherwise, 'file' gives a |
| ## file with (just) R code. |
| matches <- list() |
| TnF <- c("T", "F") |
| find_bad_exprs <- function(e, p) { |
| if(is.name(e) |
| && (as.character(e) %in% TnF) |
| && !is.null(p)) { |
| ## Need the 'list()' to deal with T/F in function |
| ## arglists which are pairlists ... |
| matches <<- c(matches, list(p)) |
| } |
| else if(is.recursive(e)) { |
| for(i in seq_along(e)) Recall(e[[i]], e) |
| } |
| } |
| exprs <- if(missing(txt)) |
| tryCatch(parse(file = file, n = -1L), |
| error = function(e) |
| stop(gettextf("parse error in file '%s':\n", |
| file, |
| .massage_file_parse_error_message(conditionMessage(e))), |
| domain = NA, call. = FALSE)) |
| else |
| tryCatch(parse(text = txt), |
| error = function(e) |
| stop(gettextf("parse error in examples from file '%s':\n", |
| file, conditionMessage(e)), |
| domain = NA, call. = FALSE)) |
| for(i in seq_along(exprs)) |
| find_bad_exprs(exprs[[i]], NULL) |
| matches |
| } |
| |
| bad_exprs <- list() |
| for(file in code_files) { |
| exprs <- find_TnF_in_code(file) |
| if(length(exprs)) { |
| exprs <- list(exprs) |
| names(exprs) <- file |
| bad_exprs <- c(bad_exprs, exprs) |
| } |
| } |
| for(file in docs_files) { |
| Rd <- prepare_Rd(file, defines = .Platform$OS.type) |
| txt <- .Rd_get_example_code(Rd) |
| exprs <- find_TnF_in_code(file, txt) |
| if(length(exprs)) { |
| exprs <- list(exprs) |
| names(exprs) <- file |
| bad_exprs <- c(bad_exprs, exprs) |
| } |
| } |
| class(bad_exprs) <- "checkTnF" |
| bad_exprs |
| } |
| |
| format.checkTnF <- |
| function(x, ...) |
| { |
| .fmt <- function(fname) { |
| xfname <- x[[fname]] |
| c(gettextf("File '%s':", fname), |
| unlist(lapply(seq_along(xfname), |
| function(i) { |
| strwrap(gettextf("found T/F in %s", |
| paste(deparse(xfname[[i]]), |
| collapse = "")), |
| exdent = 4L) |
| })), |
| "") |
| } |
| |
| as.character(unlist(lapply(names(x), .fmt))) |
| } |
| |
| ### * .check_package_depends |
| |
| ## changed in 2.3.0 to refer to a source dir. |
| |
| .check_package_depends <- |
| function(dir, force_suggests = TRUE, check_incoming = FALSE, |
| ignore_vignettes = FALSE) |
| { |
| .check_dependency_cycles <- |
| function(db, available = utils::available.packages(), |
| dependencies = c("Depends", "Imports", "LinkingTo")) |
| { |
| ## given a package, find its recursive dependencies. |
| ## We want the dependencies of the current package, |
| ## not of a version on the repository. |
| ## pkg <- db[["Package"]] |
| this <- db[dependencies]; names(this) <- dependencies |
| known <- setdiff(utils:::.clean_up_dependencies(this), "R") |
| info <- available[, dependencies, drop = FALSE] |
| rn <- rownames(info) |
| deps <- function(p) { |
| if(p %notin% rn) return(character()) |
| this <- utils:::.clean_up_dependencies(info[p, ]) |
| setdiff(this, "R") |
| } |
| extra <- known |
| repeat { |
| extra <- unlist(lapply(extra, deps)) |
| extra <- setdiff(extra, known) |
| if(!length(extra)) break |
| known <- c(known, extra) |
| } |
| known |
| } |
| |
| if(length(dir) != 1L) |
| stop("The package 'dir' argument must be of length 1") |
| |
| ## We definitely need a valid DESCRIPTION file. |
| db <- .read_description(file.path(dir, "DESCRIPTION")) |
| |
| dir_name <- basename(dir) |
| package_name <- db["Package"] |
| if(!identical(package_name, dir_name) && |
| (!is.character(package_name) || !nzchar(package_name))) { |
| message(sprintf( |
| "package name '%s' seems invalid; using directory name '%s' instead", |
| package_name, dir_name)) |
| package_name <- dir_name |
| } |
| |
| bad_depends <- list() |
| ## and we cannot have cycles |
| ## this check needs a package db from repository(s), so |
| repos <- getOption("repos") |
| if(any(grepl("@CRAN@", repos))) |
| repos <- .get_standard_repository_URLs() |
| if(!any(grepl("@CRAN@", repos))) { |
| ## Not getting here should no longer be possble ... |
| available <- utils::available.packages(repos = repos) |
| ad <- .check_dependency_cycles(db, available) |
| pkgname <- db[["Package"]] |
| if(pkgname %in% ad) |
| bad_depends$all_depends <- setdiff(ad, pkgname) |
| } else if (check_incoming) |
| bad_depends$skipped <- |
| " No repository set, so cyclic dependency check skipped" |
| |
| ldepends <- .get_requires_with_version_from_package_db(db, "Depends") |
| limports <- .get_requires_with_version_from_package_db(db, "Imports") |
| llinks <- .get_requires_with_version_from_package_db(db, "LinkingTo") |
| lsuggests <- .get_requires_with_version_from_package_db(db, "Suggests") |
| ## NB: no one checks version for 'Enhances'. |
| lenhances <- .get_requires_with_version_from_package_db(db, "Enhances") |
| ## VignetteBuilder packages are needed to ascertain what is a vignette. |
| VB <- .get_requires_from_package_db(db, "VignetteBuilder") |
| |
| depends <- sapply(ldepends, `[[`, 1L) |
| imports <- sapply(limports, `[[`, 1L) |
| links <- sapply(llinks, `[[`, 1L) |
| suggests <- sapply(lsuggests, `[[`, 1L) |
| |
| standard_package_names <- .get_standard_package_names() |
| |
| ## Are all packages listed in Depends/Suggests/Imports/LinkingTo installed? |
| lreqs <- c(ldepends, limports, llinks, |
| if(force_suggests) lsuggests) |
| lreqs2 <- c(if(!force_suggests) lsuggests, lenhances) |
| if(length(c(lreqs, lreqs2))) { |
| ## Do this directly for speed. |
| installed <- character() |
| installed_in <- character() |
| for(lib in .libPaths()) { |
| pkgs <- list.files(lib) |
| pkgs <- pkgs[file.access(file.path(lib, pkgs, "DESCRIPTION"), 4) == 0] |
| installed <- c(installed, pkgs) |
| installed_in <- c(installed_in, rep.int(lib, length(pkgs))) |
| } |
| if (length(lreqs)) { |
| reqs <- unique(sapply(lreqs, `[[`, 1L)) |
| reqs <- setdiff(reqs, installed) |
| m <- reqs %in% standard_package_names$stubs |
| if(length(reqs[!m])) { |
| bad <- reqs[!m] |
| ## EDanalysis has a package in all of Depends, Imports, Suggests. |
| bad1 <- bad[bad %in% c(depends, imports, links)] |
| if(length(bad1)) |
| bad_depends$required_but_not_installed <- bad1 |
| bad2 <- setdiff(bad, bad1) |
| if(length(bad2)) |
| bad_depends$suggested_but_not_installed <- bad2 |
| } |
| if(length(reqs[m])) |
| bad_depends$required_but_stub <- reqs[m] |
| ## now check versions |
| have_ver <- vapply(lreqs, function(x) length(x) == 3L, NA) |
| lreqs3 <- lreqs[have_ver] |
| if(length(lreqs3)) { |
| bad <- character() |
| for (r in lreqs3) { |
| pkg <- r[[1L]] |
| op <- r[[2L]] |
| where <- which(installed == pkg) |
| if(!length(where)) next |
| ## want the first one |
| desc <- readRDS(file.path(installed_in[where[1L]], pkg, |
| "Meta", "package.rds")) |
| current <- desc$DESCRIPTION["Version"] |
| target <- as.package_version(r[[3L]]) |
| if(eval(parse(text = paste("!(current", op, "target)")))) |
| bad <- c(bad, pkg) |
| } |
| if(length(bad)) |
| bad_depends$required_but_obsolete <- bad |
| } |
| } |
| if (length(lenhances) && |
| !config_val_to_logical(Sys.getenv("_R_CHECK_PACKAGE_DEPENDS_IGNORE_MISSING_ENHANCES_", |
| "FALSE"))) { |
| m <- setdiff(sapply(lenhances, `[[`, 1L), installed) |
| if(length(m)) |
| bad_depends$enhances_but_not_installed <- m |
| } |
| if (!force_suggests && length(lsuggests)) { |
| m <- setdiff(sapply(lsuggests, `[[`, 1L), installed) |
| if(length(m)) |
| bad_depends$suggests_but_not_installed <- m |
| } |
| if (!ignore_vignettes && length(VB)) { |
| ## These need both to be declared and installed |
| ## If people explicitly state 'utils' they ought really to |
| ## declare it, but skip for now. |
| bad <- VB %w/o% c(package_name, "utils", depends, imports, suggests) |
| if(length(bad)) |
| bad_depends$required_for_checking_but_not_declared <- bad |
| bad2 <- VB %w/o% c(package_name, installed) |
| bad2 <- setdiff(bad2, bad) |
| if(length(bad2)) |
| bad_depends$required_for_checking_but_not_installed <- bad2 |
| } |
| } |
| ## FIXME: is this still needed now we do dependency analysis? |
| ## Are all vignette dependencies at least suggested or equal to |
| ## the package name? |
| |
| ## This is a check for old-location vignettes. |
| ## If the package itself is the VignetteBuilder, |
| ## we may not have installed it yet. |
| defer <- package_name %in% db["VignetteBuilder"] |
| vigns <- pkgVignettes(dir = dir, subdirs = file.path("inst", "doc"), |
| check = !defer) |
| |
| if(length(vigns$msg)) |
| bad_depends$bad_engine <- vigns$msg |
| if (!is.null(vigns) && length(vigns$docs) > 0L) { |
| reqs <- unique(unlist(.build_vignette_index(vigns)$Depends)) |
| ## For the time being, ignore base packages missing from the |
| ## DESCRIPTION dependencies even if explicitly given as vignette |
| ## dependencies. |
| reqs <- setdiff(reqs, |
| c(depends, imports, suggests, package_name, |
| standard_package_names$base)) |
| if(length(reqs)) |
| bad_depends$missing_vignette_depends <- reqs |
| } |
| |
| ## Are all namespace dependencies listed as package dependencies? |
| if(file_test("-f", file.path(dir, "NAMESPACE"))) { |
| reqs <- .get_namespace_package_depends(dir) |
| ## <FIXME> |
| ## Not clear whether we want to require *all* namespace package |
| ## dependencies listed in DESCRIPTION, or e.g. just the ones on |
| ## non-base packages. Do the latter for time being ... |
| ## Actually we need to know at least about S4-using packages, |
| ## since we need to reinstall if those change. |
| allowed_imports <- |
| setdiff(standard_package_names$base, c("methods", "stats4")) |
| reqs <- setdiff(reqs, c(imports, depends, allowed_imports)) |
| if(length(reqs)) |
| bad_depends$missing_namespace_depends <- reqs |
| } |
| |
| ## Check for excessive 'Depends' |
| deps <- setdiff(depends, c("R", "base", "datasets", "grDevices", |
| "graphics", "methods", "utils", "stats")) |
| if(length(deps) > 5L) bad_depends$many_depends <- deps |
| |
| ## check header-only packages |
| if (check_incoming) { |
| hdOnly <- c("BH", "RcppArmadillo", "RcppEigen") |
| hd <- setdiff(intersect(hdOnly, c(depends, imports)), |
| .get_namespace_package_depends(dir, TRUE)) |
| if(length(hd)) bad_depends$hdOnly <- hd |
| } |
| |
| ## Check RdMacros. |
| RM <- setdiff(.get_requires_from_package_db(db, "RdMacros"), |
| c(depends, imports, suggests)) |
| if(length(RM)) bad_depends$missing_rdmacros_depends <- RM |
| |
| class(bad_depends) <- "check_package_depends" |
| bad_depends |
| } |
| |
| format.check_package_depends <- |
| function(x, ...) |
| { |
| c(character(), |
| if(length(x$skipped)) c(x$skipped, ""), |
| if(length(x$all_depends)) { |
| c("There is circular dependency in the installation order:", |
| .pretty_format2(" One or more packages in", x$all_depends), |
| " depend on this package (for the versions on the repositories).", |
| "") |
| }, |
| if(length(bad <- x$required_but_not_installed) > 1L) { |
| c(.pretty_format2("Packages required but not available:", bad), "") |
| } else if(length(bad)) { |
| c(sprintf("Package required but not available: %s", sQuote(bad)), "") |
| }, |
| if(length(bad <- x$suggested_but_not_installed) > 1L) { |
| c(.pretty_format2("Packages suggested but not available:", bad), "") |
| } else if(length(bad)) { |
| c(sprintf("Package suggested but not available: %s", sQuote(bad)), "") |
| }, |
| if(length(bad <- x$required_but_obsolete) > 1L) { |
| c(.pretty_format2("Packages required and available but unsuitable versions:", |
| bad), |
| "") |
| } else if(length(bad)) { |
| c(sprintf("Package required and available but unsuitable version: %s", sQuote(bad)), |
| "") |
| }, |
| if(length(bad <- x$required_but_stub) > 1L) { |
| c("Former standard packages required but now defunct:", |
| .pretty_format(bad), |
| "") |
| } else if(length(bad)) { |
| c(sprintf("Former standard package required but now defunct: %s", |
| sQuote(bad)), "") |
| }, |
| if(length(bad <- x$suggests_but_not_installed) > 1L) { |
| c(.pretty_format2("Packages suggested but not available for checking:", |
| bad), |
| "") |
| } else if(length(bad)) { |
| c(sprintf("Package suggested but not available for checking: %s", |
| sQuote(bad)), |
| "") |
| }, |
| if(length(bad <- x$enhances_but_not_installed) > 1L) { |
| c(.pretty_format2("Packages which this enhances but not available for checking:", |
| bad), |
| "") |
| } else if(length(bad)) { |
| c(sprintf("Package which this enhances but not available for checking: %s", sQuote(bad)), |
| "") |
| }, |
| if(length(bad <- x$required_for_checking_but_not_declared) > 1L) { |
| c(.pretty_format2("VignetteBuilder packages not declared:", bad), "") |
| } else if(length(bad)) { |
| c(sprintf("VignetteBuilder package not declared: %s", sQuote(bad)), "") |
| }, |
| if(length(bad <- x$required_for_checking_but_not_installed) > 1L) { |
| c(.pretty_format2("VignetteBuilder packages required for checking but not installed:", bad), "") |
| } else if(length(bad)) { |
| c(sprintf("VignetteBuilder package required for checking but not installed: %s", sQuote(bad)), "") |
| }, |
| if(length(bad <- x$missing_vignette_depends)) { |
| c(if(length(bad) > 1L) { |
| c("Vignette dependencies not required:", .pretty_format(bad)) |
| } else { |
| sprintf("Vignette dependency not required: %s", sQuote(bad)) |
| }, |
| strwrap(gettextf("Vignette dependencies (%s entries) must be contained in the DESCRIPTION Depends/Suggests/Imports entries.", |
| "\\VignetteDepends{}")), |
| "") |
| }, |
| if(length(bad <- x$missing_rdmacros_depends)) { |
| c(if(length(bad) > 1L) |
| .pretty_format2("RdMacros packages not required:", bad) |
| else |
| sprintf("RdMacros package not required: %s", sQuote(bad)), |
| strwrap("RdMacros packages must be contained in the DESCRIPTION Imports/Suggests/Depends entries."), |
| "") |
| }, |
| if(length(bad <- x$missing_namespace_depends) > 1L) { |
| c(.pretty_format2("Namespace dependencies not required:", bad), "") |
| } else if(length(bad)) { |
| c(sprintf("Namespace dependency not required: %s", sQuote(bad)), "") |
| }, |
| if(length(y <- x$many_depends)) { |
| c(.pretty_format2("Depends: includes the non-default packages:", y), |
| strwrap(paste("Adding so many packages to the search path", |
| "is excessive", |
| "and importing selectively is preferable." |
| , collapse = ", ")), |
| "") |
| }, |
| if(length(y <- x$bad_engine)) { |
| c(y, "") |
| }, |
| if(length(bad <- x$hdOnly)) { |
| c(if(length(bad) > 1L) |
| c("Packages in Depends/Imports which should probably only be in LinkingTo:", .pretty_format(bad)) |
| else |
| sprintf("Package in Depends/Imports which should probably only be in LinkingTo: %s", sQuote(bad)), |
| "") |
| } |
| ) |
| } |
| |
| ### * .check_package_description |
| |
| .check_package_description <- |
| function(dfile, strict = FALSE) |
| { |
| dfile <- file_path_as_absolute(dfile) |
| db <- .read_description(dfile) |
| |
| standard_package_names <- .get_standard_package_names() |
| |
| valid_package_name_regexp <- |
| .standard_regexps()$valid_package_name |
| valid_package_version_regexp <- |
| .standard_regexps()$valid_package_version |
| |
| is_base_package <- |
| !is.na(priority <- db["Priority"]) && priority == "base" |
| |
| out <- list() # For the time being ... |
| |
| ## Check encoding-related things first. |
| |
| ## All field tags must be ASCII. |
| if(any(ind <- !.is_ASCII(names(db)))) |
| out$fields_with_non_ASCII_tags <- names(db)[ind] |
| ## For all fields used by the R package management system, values |
| ## must be ASCII as well (so that the RPM works in a C locale). |
| ASCII_fields <- c(.get_standard_repository_db_fields(), |
| "Encoding", "License") |
| ASCII_fields <- intersect(ASCII_fields, names(db)) |
| if(any(ind <- !.is_ASCII(db[ASCII_fields]))) |
| out$fields_with_non_ASCII_values <- ASCII_fields[ind] |
| |
| ## Determine encoding and re-encode if necessary and possible. |
| if("Encoding" %in% names(db)) { |
| encoding <- db["Encoding"] |
| if(Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX")) |
| db <- iconv(db, encoding, sub = "byte") |
| } |
| else if(!all(.is_ISO_8859(db))) { |
| ## No valid Encoding metadata. |
| ## Determine whether we can assume Latin1. |
| out$missing_encoding <- TRUE |
| } |
| |
| if(anyNA(nchar(db, "c", TRUE))) { |
| ## Ouch, invalid in the current locale. |
| ## (Can only happen in a MBCS locale.) |
| ## Try re-encoding from Latin1. |
| db <- iconv(db, "latin1") |
| } |
| |
| ## Check Authors@R and expansion if needed. |
| if(!is.na(aar <- db["Authors@R"]) && |
| (is.na(db["Author"]) || is.na(db["Maintainer"]))) { |
| res <- .check_package_description_authors_at_R_field(aar) |
| if(is.na(db["Author"]) && |
| !is.null(s <- attr(res, "Author"))) |
| db["Author"] <- s |
| if(is.na(db["Maintainer"]) && |
| !is.null(s <- attr(res, "Maintainer"))) |
| db["Maintainer"] <- s |
| mostattributes(res) <- NULL # Keep names. |
| out <- c(out, res) |
| } |
| |
| val <- package_name <- db["Package"] |
| if(!is.na(val)) { |
| tmp <- character() |
| ## We allow 'R', which is not a valid package name. |
| if(!grepl(sprintf("^(R|%s)$", valid_package_name_regexp), val)) |
| tmp <- c(tmp, gettext("Malformed package name")) |
| if(!is_base_package) { |
| if(val %in% standard_package_names$base) |
| tmp <- c(tmp, |
| c("Invalid package name.", |
| "This is the name of a base package.")) |
| else if(val %in% standard_package_names$stubs) |
| tmp <- c(tmp, |
| c("Invalid package name.", |
| "This name was used for a base package and is remapped by library().")) |
| } |
| if(length(tmp)) |
| out$bad_package <- tmp |
| } |
| if(!is.na(val <- db["Version"]) |
| && !is_base_package |
| && !grepl(sprintf("^%s$", valid_package_version_regexp), val)) |
| out$bad_version <- val |
| if(!is.na(val <- db["Maintainer"]) |
| && !grepl(.valid_maintainer_field_regexp, val)) |
| out$bad_maintainer <- val |
| |
| ## Optional entries in DESCRIPTION: |
| ## Depends/Suggests/Imports/Enhances, Namespace, Priority. |
| ## These must be correct if present. |
| |
| val <- db[match(c("Depends", "Suggests", "Imports", "Enhances"), |
| names(db), nomatch = 0L)] |
| if(length(val)) { |
| depends <- trimws(unlist(strsplit(val, ","))) |
| bad_dep_entry <- bad_dep_op <- bad_dep_version <- character() |
| dep_regexp <- |
| paste0("^[[:space:]]*", |
| paste0("(R|", valid_package_name_regexp, ")"), |
| "([[:space:]]*\\(([^) ]+)[[:space:]]+([^) ]+)\\))?", |
| "[[:space:]]*$") |
| for(dep in depends) { |
| if(!grepl(dep_regexp, dep)) { |
| ## Entry does not match the regexp. |
| bad_dep_entry <- c(bad_dep_entry, dep) |
| next |
| } |
| if(nzchar(sub(dep_regexp, "\\2", dep))) { |
| ## If not just a valid package name ... |
| if(sub(dep_regexp, "\\3", dep) %notin% |
| c("<=", ">=", "<", ">", "==", "!=")) |
| bad_dep_op <- c(bad_dep_op, dep) |
| else if(grepl("^[[:space:]]*R", dep)) { |
| if(!grepl(sprintf("^(r[0-9]+|%s)$", |
| valid_package_version_regexp), |
| sub(dep_regexp, "\\4", dep))) |
| bad_dep_version <- c(bad_dep_version, dep) |
| } else if(!grepl(sprintf("^%s$", |
| valid_package_version_regexp), |
| sub(dep_regexp, "\\4", dep))) |
| bad_dep_version <- c(bad_dep_version, dep) |
| } |
| } |
| if(length(c(bad_dep_entry, bad_dep_op, bad_dep_version))) |
| out$bad_depends_or_suggests_or_imports <- |
| list(bad_dep_entry = bad_dep_entry, |
| bad_dep_op = bad_dep_op, |
| bad_dep_version = bad_dep_version) |
| } |
| if(strict && !is.na(val <- db["VignetteBuilder"])) { |
| depends <- trimws(unlist(strsplit(val, ","))) |
| if(length(depends) < 1L || !all(grepl("^[[:alnum:].]*$", depends))) |
| out$bad_vignettebuilder <- TRUE |
| } |
| if(!is.na(val <- db["Priority"]) |
| && !is.na(package_name) |
| && (tolower(val) %in% c("base", "recommended", "defunct-base")) |
| && (package_name %notin% unlist(standard_package_names))) |
| out$bad_priority <- val |
| |
| ## Minimal check (so far) of Title and Description. |
| if(strict && !is.na(val <- db["Title"]) |
| && endsWith(val, ".") |
| && !grepl("[[:space:]][.][.][.]|et[[:space:]]al[.]", trimws(val))) |
| out$bad_Title <- TRUE |
| ## some people put punctuation inside quotes, some outside. |
| if(strict && !is.na(val <- db["Description"]) |
| && !grepl("[.!?]['\")]?$", trimws(val))) |
| out$bad_Description <- TRUE |
| |
| class(out) <- "check_package_description" |
| out |
| } |
| |
| print.check_package_description <- |
| function(x, ...) |
| { |
| if(length(x$missing_encoding)) |
| writeLines(c(gettext("Unknown encoding"), "")) |
| |
| if(length(x$fields_with_non_ASCII_tags)) { |
| writeLines(gettext("Fields with non-ASCII tags:")) |
| .pretty_print(x$fields_with_non_ASCII_tags) |
| writeLines(c(gettext("All field tags must be ASCII."), "")) |
| } |
| |
| if(length(x$fields_with_non_ASCII_values)) { |
| writeLines(gettext("Fields with non-ASCII values:")) |
| .pretty_print(x$fields_with_non_ASCII_values) |
| writeLines(c(gettext("These fields must have ASCII values."), "")) |
| } |
| |
| s <- .format_check_package_description_authors_at_R_field_results(x) |
| if(length(s)) |
| writeLines(c(s, "")) |
| |
| ## if(length(x$missing_required_fields)) { |
| ## writeLines(gettext("Required fields missing or empty:")) |
| ## .pretty_print(x$missing_required_fields) |
| ## writeLines("") |
| ## } |
| |
| if(length(x$bad_package)) |
| writeLines(c(strwrap(x$bad_package), "")) |
| |
| if(length(x$bad_version)) |
| writeLines(c(gettext("Malformed package version."), "")) |
| |
| if(length(x$bad_maintainer)) |
| writeLines(c(gettext("Malformed maintainer field."), "")) |
| |
| if(any(as.integer(lengths(x$bad_depends_or_suggests_or_imports)) > 0L )) { |
| bad <- x$bad_depends_or_suggests_or_imports |
| writeLines(gettext("Malformed Depends or Suggests or Imports or Enhances field.")) |
| if(length(bad$bad_dep_entry)) { |
| tmp <- c(gettext("Offending entries:"), |
| paste0(" ", bad$bad_dep_entry), |
| strwrap(gettextf("Entries must be names of packages optionally followed by '<=' or '>=', white space, and a valid version number in parentheses."))) |
| writeLines(tmp) |
| } |
| if(length(bad$bad_dep_op)) { |
| tmp <- c(gettext("Entries with infeasible comparison operator:"), |
| paste0(" ", bad$bad_dep_entry), |
| strwrap(gettextf("Only operators '<=' and '>=' are possible."))) |
| |
| writeLines(tmp) |
| } |
| if(length(bad$bad_dep_version)) { |
| tmp <- c(gettext("Entries with infeasible version number:"), |
| paste0(" ", bad$bad_dep_version), |
| strwrap(gettextf("Version numbers must be sequences of at least two non-negative integers, separated by single '.' or '-'."))) |
| writeLines(tmp) |
| } |
| writeLines("") |
| } |
| if(isTRUE(x$bad_vignettebuilder)) { |
| writeLines(c(gettext("Invalid VignetteBuilder field."), |
| strwrap(gettextf("This field must contain one or more packages (and no version requirement).")), |
| "")) |
| } |
| |
| if(length(x$bad_priority)) |
| writeLines(c(gettext("Invalid Priority field."), |
| strwrap(gettextf("Packages with priorities 'base' or 'recommended' or 'defunct-base' must already be known to R.")), |
| "")) |
| |
| if(isTRUE(x$bad_Title)) |
| writeLines(gettext("Malformed Title field: should not end in a period.")) |
| |
| if(isTRUE(x$bad_Description)) |
| writeLines(gettext("Malformed Description field: should contain one or more complete sentences.")) |
| |
| xx<- x; xx$bad_Title <- xx$bad_Description <- NULL |
| |
| if(any(as.integer(lengths(xx)) > 0L)) |
| writeLines(c(strwrap(gettextf("See section 'The DESCRIPTION file' in the 'Writing R Extensions' manual.")), |
| "")) |
| |
| invisible(x) |
| } |
| |
| ### * .check_package_description2 |
| |
| .check_package_description2 <- |
| function(dfile) |
| { |
| dfile <- file_path_as_absolute(dfile) |
| db <- .read_description(dfile) |
| depends <- .get_requires_from_package_db(db, "Depends") |
| imports <- .get_requires_from_package_db(db, "Imports") |
| suggests <- .get_requires_from_package_db(db, "Suggests") |
| enhances <- .get_requires_from_package_db(db, "Enhances") |
| allpkgs <- c(depends, imports, suggests, enhances) |
| out <- unique(allpkgs[duplicated(allpkgs)]) |
| links <- missing_incs <- character() |
| llinks <- .get_requires_with_version_from_package_db(db, "LinkingTo") |
| have_src <- TRUE # dummy |
| if(length(llinks)) { |
| ## This is pointless unless there is compilable code |
| have_src <- dir.exists(file.path(dirname(dfile), "src")) |
| |
| ## See if this is installable under 3.0.1: |
| ## if so check for versioned specs |
| deps <- .split_description(db, verbose = TRUE)$Rdepends2 |
| status <- 0L |
| current <- as.numeric_version("3.0.1") |
| for(depends in deps) { |
| if(depends$op %notin% c("<=", ">=", "<", ">", "==", "!=")) next |
| status <- if(inherits(depends$version, "numeric_version")) |
| !do.call(depends$op, list(current, depends$version)) |
| else { |
| ver <- R.version |
| if (ver$status %in% c("", "Patched")) FALSE |
| else !do.call(depends$op, |
| list(ver[["svn rev"]], |
| as.numeric(sub("^r", "", depends$version)))) |
| } |
| } |
| if(!status) { |
| llinks <- llinks[lengths(llinks) > 1L] |
| if(length(llinks)) links <- sapply(llinks, `[[`, 1L) |
| } |
| ## and check if we can actually link to these. |
| llinks <- .get_requires_from_package_db(db, "LinkingTo") |
| incs <- lapply(llinks, function(x) system.file("include", package = x)) |
| missing_incs <- as.vector(llinks[!nzchar(incs)]) |
| } |
| out <- list(duplicates = unique(allpkgs[duplicated(allpkgs)]), |
| bad_links = links, missing_incs = missing_incs, |
| have_src = have_src) |
| class(out) <- "check_package_description2" |
| out |
| } |
| |
| format.check_package_description2 <- function(x, ...) |
| { |
| c(if(length(xx <- x$duplicates)) { |
| c(if(length(xx) > 1L) |
| "Packages listed in more than one of Depends, Imports, Suggests, Enhances:" |
| else |
| "Package listed in more than one of Depends, Imports, Suggests, Enhances:", |
| paste(c(" ", sQuote(xx)), collapse = " "), |
| "A package should be listed in only one of these fields.") |
| }, |
| if(!x$have_src) "'LinkingTo' field is unused: package has no 'src' directory", |
| if(length(xx <- x$bad_links)) { |
| if(length(xx) > 1L) |
| c("Versioned 'LinkingTo' values for", |
| paste(c(" ", sQuote(xx)), collapse = " "), |
| "are only usable in R >= 3.0.2") |
| else |
| sprintf("Versioned 'LinkingTo' value for %s is only usable in R >= 3.0.2", |
| sQuote(xx)) |
| }, |
| if(x$have_src && length(xx <- x$missing_incs)) { |
| if(length(xx) > 1L) |
| c("'LinkingTo' for", |
| paste(c(" ", sQuote(xx)), collapse = " "), |
| "are unused as they have no 'include' directory") |
| else |
| sprintf("'LinkingTo' for %s is unused as it has no 'include' directory", sQuote(xx)) |
| }) |
| } |
| |
| .check_package_description_authors_at_R_field <- |
| function(aar, strict = FALSE) |
| { |
| out <- list() |
| if(is.na(aar)) return(out) |
| aar <- tryCatch(utils:::.read_authors_at_R_field(aar), |
| error = identity) |
| if(inherits(aar, "error")) { |
| out$bad_authors_at_R_field <- conditionMessage(aar) |
| } else { |
| ## Check whether we can expand to something non-empty. |
| s <- tryCatch(utils:::.format_authors_at_R_field_for_author(aar), |
| error = identity) |
| if(inherits(s, "error")) { |
| out$bad_authors_at_R_field_for_author <- |
| conditionMessage(s) |
| } else { |
| if(s == "") |
| out$bad_authors_at_R_field_has_no_author <- TRUE |
| else { |
| attr(out, "Author") <- s |
| if(strict >= 1L) { |
| has_no_name <- |
| vapply(aar, |
| function(e) |
| is.null(e$given) && is.null(e$family), |
| NA) |
| if(any(has_no_name)) { |
| out$bad_authors_at_R_field_has_persons_with_no_name <- |
| format(aar[has_no_name]) |
| } |
| has_no_role <- |
| vapply(aar, |
| function(e) is.null(e$role), |
| NA) |
| if(any(has_no_role)) { |
| out$bad_authors_at_R_field_has_persons_with_no_role <- |
| format(aar[has_no_role]) |
| } |
| } |
| if(strict >= 2L) { |
| if(all(has_no_name | |
| vapply(aar, |
| function(e) |
| is.na(match("aut", e$role)), |
| NA))) |
| out$bad_authors_at_R_field_has_no_author_roles <- TRUE |
| } |
| if(strict >= 3L) { |
| non_standard_roles <- |
| lapply(aar$role, setdiff, |
| utils:::MARC_relator_db_codes_used_with_R) |
| ind <- lengths(non_standard_roles) > 0L |
| if(any(ind)) { |
| out$authors_at_R_field_has_persons_with_nonstandard_roles <- |
| sprintf("%s: %s", |
| format(aar[ind]), |
| vapply(non_standard_roles[ind], paste, |
| collapse = ", ", |
| FUN.VALUE = "")) |
| } |
| } |
| } |
| } |
| s <- tryCatch(utils:::.format_authors_at_R_field_for_maintainer(aar), |
| error = identity) |
| if(inherits(s, "error")) { |
| out$bad_authors_at_R_field_for_maintainer <- |
| conditionMessage(s) |
| } else { |
| ## R-exts says |
| ## The mandatory 'Maintainer' field should give a _single_ |
| ## name followed by a _valid_ (RFC 2822) email address in |
| ## angle brackets. |
| ## Hence complain when Authors@R |
| ## * has more than one person with a cre role |
| ## * has no person with a cre role, "valid" email address |
| ## and a non-empty name. |
| bad <- FALSE |
| p <- Filter(function(e) { |
| !is.na(match("cre", e$role)) |
| }, |
| aar) |
| if(length(p) > 1L) { |
| bad <- TRUE |
| out$bad_authors_at_R_field_too_many_maintainers <- |
| format(p) |
| } |
| p <- Filter(function(e) { |
| (!is.null(e$given) || !is.null(e$family)) && !is.null(e$email) |
| }, |
| p) |
| if(!length(p)) { |
| bad <- TRUE |
| out$bad_authors_at_R_field_has_no_valid_maintainer <- TRUE |
| } |
| ## s should now be non-empty iff bad is FALSE. |
| if(!bad) attr(out, "Maintainer") <- s |
| } |
| } |
| out |
| } |
| |
| .format_check_package_description_authors_at_R_field_results <- |
| function(x) |
| { |
| c(character(), |
| if(length(bad <- x[["bad_authors_at_R_field"]])) { |
| c(gettext("Malformed Authors@R field:"), |
| paste0(" ", bad)) |
| }, |
| if(length(bad <- x[["bad_authors_at_R_field_for_author"]])) { |
| c(gettext("Cannot extract Author field from Authors@R field:"), |
| paste0(" ", bad)) |
| }, |
| if(length(x[["bad_authors_at_R_field_has_no_author"]])) { |
| gettext("Authors@R field gives no person with name and roles.") |
| }, |
| if(length(bad <- |
| x[["bad_authors_at_R_field_has_persons_with_no_name"]])) { |
| c(gettext("Authors@R field gives persons with no name:"), |
| paste0(" ", bad)) |
| }, |
| if(length(bad <- |
| x[["bad_authors_at_R_field_has_persons_with_no_role"]])) { |
| c(gettext("Authors@R field gives persons with no role:"), |
| paste0(" ", bad)) |
| }, |
| if(length(x[["bad_authors_at_R_field_has_no_author_roles"]])) { |
| gettext("Authors@R field gives no person with name and author role") |
| }, |
| ## if(length(bad <- |
| ## x[["authors_at_R_field_has_persons_with_nonstandard_roles"]])) { |
| ## c(gettext("Authors@R field gives persons with non-standard roles:"), |
| ## paste0(" ", bad)) |
| ## }, |
| if(length(bad <- x[["bad_authors_at_R_field_for_maintainer"]])) { |
| c(gettext("Cannot extract Maintainer field from Authors@R field:"), |
| paste0(" ", bad)) |
| }, |
| if(length(bad <- |
| x[["bad_authors_at_R_field_too_many_maintainers"]])) { |
| c(gettext("Authors@R field gives more than one person with maintainer role:"), |
| paste0(" ", bad)) |
| }, |
| if(length(x[["bad_authors_at_R_field_has_no_valid_maintainer"]])) { |
| strwrap(gettext("Authors@R field gives no person with maintainer role, valid email address and non-empty name.")) |
| } |
| ) |
| } |
| |
| ### * .check_package_description_encoding |
| |
| .check_package_description_encoding <- |
| function(dfile) |
| { |
| dfile <- file_path_as_absolute(dfile) |
| db <- .read_description(dfile) |
| out <- list() |
| |
| ## Check encoding-related things. |
| |
| ## All field tags must be ASCII. |
| if(any(ind <- !.is_ASCII(names(db)))) |
| out$fields_with_non_ASCII_tags <- names(db)[ind] |
| |
| if("Encoding" %notin% names(db)) { |
| ind <- !.is_ASCII(db) |
| if(any(ind)) { |
| out$missing_encoding <- TRUE |
| out$fields_with_non_ASCII_values <- names(db)[ind] |
| } |
| } else { |
| enc <- db[["Encoding"]] |
| if (enc %notin% c("latin1", "latin2", "UTF-8")) |
| out$non_portable_encoding <- enc |
| } |
| |
| class(out) <- "check_package_description_encoding" |
| out |
| } |
| |
| format.check_package_description_encoding <- |
| function(x, ...) |
| { |
| c(character(), |
| if(length(x$non_portable_encoding)) { |
| c(gettextf("Encoding '%s' is not portable", |
| x$non_portable_encoding), |
| "") |
| }, |
| if(length(x$missing_encoding)) { |
| gettext("Unknown encoding with non-ASCII data") |
| }, |
| if(length(x$fields_with_non_ASCII_tags)) { |
| c(gettext("Fields with non-ASCII tags:"), |
| .pretty_format(x$fields_with_non_ASCII_tags), |
| gettext("All field tags must be ASCII."), |
| "") |
| }, |
| if(length(x$fields_with_non_ASCII_values)) { |
| c(gettext("Fields with non-ASCII values:"), |
| .pretty_format(x$fields_with_non_ASCII_values)) |
| }, |
| if(any(as.integer(lengths(x)) > 0L)) { |
| c(strwrap(gettextf("See section 'The DESCRIPTION file' in the 'Writing R Extensions' manual.")), |
| "") |
| }) |
| } |
| |
| ### * .check_package_license |
| |
| .check_package_license <- |
| function(dfile, dir) |
| { |
| dfile <- file_path_as_absolute(dfile) |
| db <- .read_description(dfile) |
| |
| if(missing(dir)) |
| dir <- dirname(dfile) |
| |
| ## Analyze the license information here. |
| ## Cannot easily do this in .check_package_description(), as R CMD |
| ## check's R::Utils::check_package_description() takes any output |
| ## from this as indication of an error. |
| |
| out <- list() |
| if(!is.na(val <- db["License"])) { |
| ## If there is no License field, .check_package_description() |
| ## will give an error. |
| status <- analyze_license(val) |
| ok <- status$is_canonical |
| ## This analyzes the license specification but does not verify |
| ## whether pointers exist, so let us do this here. |
| if(length(pointers <- status$pointers)) { |
| bad_pointers <- |
| pointers[!file_test("-f", file.path(dir, pointers))] |
| if(length(bad_pointers)) { |
| status$bad_pointers <- bad_pointers |
| ok <- FALSE |
| } |
| } |
| patt <- "(^Modified BSD License$|^BSD$|^CC BY.* [23][.]0)" |
| if(any(ind <- grepl(patt, status$component))) { |
| status$deprecated <- status$components[ind] |
| ok <- FALSE |
| } |
| ## Components with extensions but not extensible: |
| if(length(extensions <- status$extensions) && |
| any(ind <- !extensions$extensible)) { |
| status$bad_extensions <- extensions$components[ind] |
| ok <- FALSE |
| } |
| ## Components which need extensions (note that such components |
| ## could use the name or abbrev from the license db): |
| if(any(ind <- status$components %in% |
| c("MIT License", "MIT", |
| "BSD 2-clause License", "BSD_2_clause", |
| "BSD 3-clause License", "BSD_3_clause"))) { |
| status$miss_extension <- status$components[ind] |
| ok <- FALSE |
| } |
| ## Could always return the analysis results and not print them |
| ## if ok, but it seems more standard to only return trouble. |
| if(!ok) |
| out <- c(list(license = val), status) |
| } |
| |
| class(out) <- "check_package_license" |
| out |
| } |
| |
| format.check_package_license <- |
| function(x, ...) |
| { |
| if(!length(x)) |
| return(character()) |
| |
| check <- Sys.getenv("_R_CHECK_LICENSE_") |
| check <- if(check %in% c("maybe", "")) |
| (!(x$is_standardizable) |
| || length(x$bad_pointers) |
| || length(x$bad_extensions)) |
| else |
| isTRUE(as.logical(check)) |
| if(!check) |
| return(character()) |
| |
| c(character(), |
| if(!(x$is_canonical)) { |
| c(gettext("Non-standard license specification:"), |
| strwrap(x$license, indent = 2L, exdent = 2L), |
| gettextf("Standardizable: %s", x$is_standardizable), |
| if(x$is_standardizable) { |
| c(gettext("Standardized license specification:"), |
| strwrap(x$standardization, indent = 2L, exdent = 2L)) |
| }) |
| }, |
| if(length(y <- x$deprecated)) { |
| c(gettextf("Deprecated license: %s", |
| paste(y, collapse = " "))) |
| }, |
| if(length(y <- x$bad_pointers)) { |
| c(gettextf("Invalid license file pointers: %s", |
| paste(y, collapse = " "))) |
| }, |
| if(length(y <- x$bad_extensions)) { |
| c(gettext("License components with restrictions not permitted:"), |
| paste0(" ", y)) |
| }, |
| if(length(y <- x$miss_extension)) { |
| c(gettext("License components which are templates and need '+ file LICENSE':"), |
| paste0(" ", y)) |
| } |
| ) |
| } |
| |
| ### * .check_make_vars |
| |
| .check_make_vars <- |
| function(dir, makevars = c("Makevars.in", "Makevars")) |
| { |
| bad_flags <- list() |
| class(bad_flags) <- "check_make_vars" |
| |
| paths <- file.path(dir, makevars) |
| paths <- paths[file_test("-f", paths)] |
| if(!length(paths)) return(bad_flags) |
| bad_flags$paths <- file.path("src", basename(paths)) |
| ## Makevars could be used with --no-configure |
| ## and maybe configure does not even use src/Makevars.in |
| mfile <- paths[1L] |
| make <- Sys.getenv("MAKE") |
| if(make == "") make <- "make" |
| ## needs a target to avoid targets in src/Makevars |
| command <- sprintf("%s -f %s -f %s -f %s makevars_test", |
| make, |
| shQuote(file.path(R.home("share"), "make", |
| "check_vars_ini.mk")), |
| shQuote(mfile), |
| shQuote(file.path(R.home("share"), "make", |
| "check_vars_out.mk"))) |
| lines <- suppressWarnings(tryCatch(system(command, intern = TRUE, |
| ignore.stderr = TRUE), |
| error = identity)) |
| if(!length(lines) || inherits(lines, "error")) |
| return(bad_flags) |
| |
| prefixes <- c("CPP", "C", "CXX", "CXX98", "CXX11", "CXX14", "CXX17", "F", "FC", "OBJC", "OBJCXX") |
| |
| uflags_re <- sprintf("^(%s)FLAGS: *(.*)$", |
| paste(prefixes, collapse = "|")) |
| pos <- grep(uflags_re, lines) |
| ind <- (sub(uflags_re, "\\2", lines[pos]) != "-o /dev/null") |
| if(any(ind)) |
| bad_flags$uflags <- lines[pos[ind]] |
| |
| ## Try to be careful ... |
| pflags_re <- sprintf("^PKG_(%s)FLAGS: ", |
| paste(prefixes, collapse = "|")) |
| lines <- lines[grepl(pflags_re, lines)] |
| names <- sub(":.*", "", lines) |
| lines <- sub(pflags_re, "", lines) |
| flags <- strsplit(lines, "[[:space:]]+") |
| ## Bad flags: |
| ## -O* |
| ## (BDR: for example Sun Fortran compilers used to accept -O |
| ## but not -O2, and VC++ accepts -Ox (literal x) but not -O.) |
| ## -Wall -pedantic -ansi -traditional -std* -f* -m* [GCC] |
| ## -x [Solaris] |
| ## -q [AIX] |
| ## It is hard to think of anything apart from -I* and -D* that is |
| ## safe for general use ... |
| bad_flags_regexp <- |
| sprintf("^-(%s)$", |
| paste(c("O.*", |
| "W", # same as -Wextra in GCC. |
| "w", # GCC, Solaris inhibit all warnings |
| "W[^l].*", # -Wl, might just be portable |
| "ansi", "pedantic", "traditional", |
| "f.*", "m.*", "std.*", # includes -fopenmp |
| "isystem", # gcc and clones |
| "x", |
| "cpp", # gfortran |
| "g", # not portable, waste of space |
| "q"), |
| collapse = "|")) |
| for(i in seq_along(lines)) { |
| bad <- grep(bad_flags_regexp, flags[[i]], value = TRUE) |
| if(length(bad)) |
| bad_flags$pflags <- |
| c(bad_flags$pflags, |
| structure(list(bad), names = names[i])) |
| } |
| |
| ## The above does not know about GNU extensions like |
| ## target.o: PKG_CXXFLAGS = -mavx |
| ## so grep files directly. |
| for (f in paths) { |
| lines <- readLines(f, warn = FALSE) |
| pflags_re2 <- sprintf(".*[.o]: +PKG_(%s)FLAGS *=", |
| paste(prefixes, collapse = "|")) |
| lines <- grep(pflags_re2, lines, value = TRUE) |
| lines <- sub(pflags_re2, "", lines) |
| flags <- strsplit(lines, "[[:space:]]+") |
| bad <- character() |
| for(i in seq_along(lines)) |
| bad <- c(bad, grep(bad_flags_regexp, flags[[i]], value = TRUE)) |
| |
| if(length(bad)) |
| bad_flags$p2flags <- |
| c(bad_flags$p2flags, |
| structure(list(bad), names = file.path("src", basename(f)))) |
| } |
| |
| bad_flags |
| } |
| |
| format.check_make_vars <- |
| function(x, ...) |
| { |
| .fmt <- function(x) { |
| s <- Map(c, |
| gettextf("Non-portable flags in variable '%s':", |
| names(x)), |
| sprintf(" %s", lapply(x, paste, collapse = " "))) |
| as.character(unlist(s)) |
| } |
| |
| .fmt2 <- function(x) { |
| s <- Map(c, |
| gettextf("Non-portable flags in file '%s':", |
| names(x)), |
| sprintf(" %s", lapply(x, paste, collapse = " "))) |
| as.character(unlist(s)) |
| } |
| |
| c(character(), |
| if(length(bad <- x$pflags)) .fmt(bad), |
| if(length(bad <- x$p2flags)) .fmt2(bad), |
| if(length(bad <- x$uflags)) { |
| c(gettextf("Variables overriding user/site settings:"), |
| sprintf(" %s", bad)) |
| }, |
| if(length(x$paths) > 1L) { |
| c(sprintf("Package has both %s and %s.", |
| sQuote("src/Makevars.in"), sQuote("src/Makevars")), |
| strwrap(sprintf("Installation with --no-configure' is unlikely to work. If you intended %s to be used on Windows, rename it to %s otherwise remove it. If %s created %s, you need a %s script.", |
| sQuote("src/Makevars"), |
| sQuote("src/Makevars.win"), |
| sQuote("configure"), |
| sQuote("src/Makevars"), |
| sQuote("cleanup")))) |
| }) |
| } |
| |
| ### * .check_code_usage_in_package |
| |
| ## First, its auxiliaries |
| ## |
| ## - .unix_only_proto_objects |
| ## - .windows_only_proto_objects |
| ## - compatibilityEnv () -- used also in codoc() |
| |
| .unix_only_proto_objects <- as.environment(list( |
| nsl = function(hostname) {} |
| , X11Font = function(font) {} |
| , X11Fonts = function(...) {} |
| , X11.options = function(..., reset = TRUE) {} |
| , quartz = function(title, width, height, pointsize, family, |
| fontsmooth, antialias, type, file = NULL, |
| bg, canvas, dpi) {} |
| , quartzFont = function(family) {} |
| , quartzFonts = function(...) {} |
| , quartz.options = function(..., reset = TRUE) {} |
| , quartz.save = function(file, type = "png", device = dev.cur(), |
| dpi = 100, ...) {} |
| )) |
| |
| .windows_only_proto_objects <- as.environment(list( |
| arrangeWindows = function(action = c("vertical", "horizontal", |
| "cascade", "minimize", "restore"), |
| windows, preserve = TRUE, outer = FALSE) {} |
| , askYesNoWinDialog = function(msg, ...) {} |
| , bringToTop = function(which = grDevices::dev.cur(), stay = FALSE) {} |
| , choose.dir = function(default = "", caption = "Select folder") {} |
| , choose.files = function(default = "", caption = "Select files", multi = TRUE, |
| filters = Filters, index = nrow(Filters)) { |
| Filters <- NULL } |
| , close.winProgressBar = function(con, ...) {} |
| , DLL.version = function(path) {} |
| , getClipboardFormats = function(numeric = FALSE) {} |
| , getIdentification = function() {} |
| , getWindowsHandle = function(which = "Console") {} |
| , getWindowsHandles = function(which = "R", pattern = "", minimized = FALSE) {} |
| , getWindowTitle = function() {} |
| , getWinProgressBar = function(pb) {} |
| , .install.winbinary = function(pkgs, lib, repos = getOption("repos"), |
| contriburl = utils::contrib.url(repos), |
| method, available = NULL, destdir = NULL, |
| dependencies = FALSE, libs_only = FALSE, ...) {} |
| , loadRconsole = function(file = choose.files(file.path( |
| Sys.getenv("R_USER"), "Rconsole"))) {} |
| , msgWindow = function(type = c("minimize", "restore", "maximize", "hide", |
| "recordOn", "recordOff"), |
| which = dev.cur()) {} |
| , readClipboard = function(format = 1, raw = FALSE) {} |
| , readRegistry = function(key, |
| hive = c("HLM", "HCR", "HCU", "HU", "HCC", "HPD"), |
| maxdepth = 1, |
| view = c("default", "32-bit", "64-bit")) {} |
| ## Exists on all platforms though with differing formals : |
| ## , savePlot = function(filename = "Rplot", |
| ## type = c("wmf", "emf", "png", "jpeg", "jpg", |
| ## "bmp", "ps", "eps", "pdf"), |
| ## device = grDevices::dev.cur(), restoreConsole = TRUE) {} |
| , setStatusBar = function(text) {} |
| , setWindowTitle = function(suffix, title = paste(utils::getIdentification(), |
| suffix)) {} |
| , setWinProgressBar = function(pb, value, title=NULL, label=NULL) {} |
| , shell = function(cmd, shell, flag = "/c", intern = FALSE, |
| wait = TRUE, translate = FALSE, mustWork = FALSE, ...) {} |
| , shell.exec = function(file) {} |
| , shortPathName = function(path) {} |
| , Sys.junction = function(from, to) {} |
| , win.graph = function(width = 7, height = 7, pointsize = 12, |
| restoreConsole = FALSE) {} |
| , win.metafile = function(filename = "", width = 7, height = 7, |
| pointsize = 12, family = "", |
| restoreConsole = TRUE) {} |
| , win.print = function(width = 7, height = 7, pointsize = 12, |
| printer = "", family = "", antialias = "default", |
| restoreConsole = TRUE) {} |
| , win.version = function() {} |
| , windows = function(width, height, pointsize, |
| record, rescale, xpinch, ypinch, |
| bg, canvas, gamma, xpos, ypos, |
| buffered, title, restoreConsole, clickToConfirm, |
| fillOddEven, family = "", antialias) {} |
| , windowsFont = function(font) {} |
| , windowsFonts = function(...) {} |
| , windows.options = function(..., reset = TRUE) {} |
| , winDialog = function(type = "ok", message) {} |
| , winDialogString = function(message, default) {} |
| , winMenuAdd = function(menuname) {} |
| , winMenuAddItem = function(menuname, itemname, action) {} |
| , winMenuDel = function(menuname) {} |
| , winMenuDelItem = function(menuname, itemname) {} |
| , winMenuNames = function() {} |
| , winMenuItems = function(menuname) {} |
| , winProgressBar = function(title = "R progress bar", label = "", |
| min = 0, max = 1, initial = 0, width = 300) {} |
| , writeClipboard = function(str, format = 1L) {} |
| , zip.unpack = function(zipname, dest) {} |
| )) |
| |
| compatibilityEnv <- function() { |
| ## (this formulation allows more than two OS.type s) |
| switch(.Platform$OS.type, |
| "windows" = .unix_only_proto_objects, |
| "unix" = .windows_only_proto_objects, |
| ## in such a future case, possibly the "union" of these environments: |
| stop(gettextf("invalid 'OS.type' \"%s\". Should not happen"))) |
| } |
| |
| .check_code_usage_in_package <- |
| function(package, lib.loc = NULL) |
| { |
| is_base <- package == "base" |
| |
| check_without_loading <- |
| config_val_to_logical(Sys.getenv("_R_CHECK_CODE_USAGE_VIA_NAMESPACES_", |
| "TRUE")) |
| |
| if(!is_base) { |
| if(!check_without_loading) { |
| .load_package_quietly(package, lib.loc) |
| .eval_with_capture({ |
| ## avoid warnings about code in other packages the package |
| ## uses |
| desc <- readRDS(file.path(find.package(package, NULL), |
| "Meta", "package.rds")) |
| pkgs1 <- sapply(desc$Suggests, "[[", "name") |
| pkgs2 <- sapply(desc$Enhances, "[[", "name") |
| for(pkg in unique(c(pkgs1, pkgs2))) |
| ## tcltk warns if no DISPLAY variable |
| ##, errors if not compiled in |
| suppressMessages( |
| tryCatch(require(pkg, character.only = TRUE, |
| quietly = TRUE), |
| error = function(.) NULL, |
| warning= function(.) NULL)) |
| }, type = "output") |
| } |
| if(is.null(.GlobalEnv$.Random.seed)) # create .Random.seed if necessary |
| stats::runif(1) |
| attach(compatibilityEnv(), name="compat", pos = length(search()), |
| warn.conflicts = FALSE) |
| on.exit(detach("compat")) |
| } |
| |
| ## A simple function for catching the output from the codetools |
| ## analysis using the checkUsage report mechanism. |
| out <- character() |
| foo <- function(x) out <<- c(out, x) |
| ## (Simpler than using a variant of capture.output().) |
| ## Of course, it would be nice to return a suitably structured |
| ## result, but we can always do this by suitably splitting the |
| ## messages on the double colons ... |
| |
| ## Not only check function definitions, but also S4 methods |
| ## [a version of this should be part of codetools eventually] : |
| checkMethodUsageEnv <- function(env, ...) { |
| for(g in .get_S4_generics(env)) |
| for(m in .get_S4_methods_list(g, env)) { |
| fun <- methods::unRematchDefinition(methods::getDataPart(m)) |
| signature <- paste(m@generic, |
| paste(m@target, collapse = "-"), |
| sep = ",") |
| codetools::checkUsage(fun, signature, ...) |
| } |
| } |
| checkMethodUsagePackage <- function (pack, ...) { |
| pname <- paste0("package:", pack) |
| if (pname %notin% search()) |
| stop("package must be loaded", domain = NA) |
| checkMethodUsageEnv(if (isNamespaceLoaded(pack)) |
| getNamespace(pack) else as.environment(pname), ...) |
| } |
| |
| ## Allow specifying a codetools "profile" for checking via the |
| ## environment variable _R_CHECK_CODETOOLS_PROFILE_, used as e.g. |
| ## _R_CHECK_CODETOOLS_PROFILE_="suppressLocalUnused=FALSE" |
| ## (where the values get converted to logicals "the usual way"). |
| args <- list(skipWith = TRUE, |
| suppressPartialMatchArgs = FALSE, |
| suppressLocalUnused = TRUE) |
| opts <- unlist(strsplit(Sys.getenv("_R_CHECK_CODETOOLS_PROFILE_"), |
| "[[:space:]]*,[[:space:]]*")) |
| if(length(opts)) { |
| args[sub("[[:space:]]*=.*", "", opts)] <- |
| lapply(sub(".*=[[:space:]]*", "", opts), |
| config_val_to_logical) |
| } |
| if(check_without_loading) |
| env <- suppressWarnings(suppressMessages(getNamespace(package))) |
| ## look for globalVariables declaration in package |
| ## (This loads the namespace if not already loaded.) |
| .glbs <- suppressMessages(utils::globalVariables(, package)) |
| if(length(.glbs)) { |
| ## Cannot use globalVariables() for base |
| ## (and potentially tools and utils) |
| dflt <- c(if(package == "base") "last.dump", |
| ".Generic", ".Method", ".Class") |
| args$suppressUndefined <- c(dflt, .glbs) |
| } |
| |
| if(check_without_loading) { |
| args <- c(list(env, report = foo), args) |
| suppressMessages(do.call(codetools::checkUsageEnv, args)) |
| suppressMessages(do.call(checkMethodUsageEnv, args)) |
| } else { |
| args <- c(list(package, report = foo), args) |
| suppressMessages(do.call(codetools::checkUsagePackage, args)) |
| suppressMessages(do.call(checkMethodUsagePackage, args)) |
| } |
| |
| out <- unique(out) |
| class(out) <- "check_code_usage_in_package" |
| out |
| } |
| |
| format.check_code_usage_in_package <- |
| function(x, ...) |
| { |
| if(length(x)) { |
| ## There seems no easy we can gather usage diagnostics by type, |
| ## so try to rearrange to some extent when formatting. |
| ind <- grepl(": partial argument match of", x, fixed = TRUE) |
| if(any(ind)) x <- c(x[ind], x[!ind]) |
| } |
| if(length(x)) { |
| ## Provide a summary listing of the undefined globals: |
| y <- .canonicalize_quotes(x) |
| m <- regexec("no visible global function definition for '(.*)'", y) |
| funs <- vapply(Filter(length, regmatches(y, m)), `[`, "", 2L) |
| m <- regexec("no visible binding for global variable '(.*)'", y) |
| vars <- vapply(Filter(length, regmatches(y, m)), `[`, "", 2L) |
| y <- sort(unique(c(funs, vars))) |
| c(strwrap(x, indent = 0L, exdent = 2L), |
| if(length(y)) { |
| c("Undefined global functions or variables:", |
| strwrap(paste(y, collapse = " "), |
| indent = 2L, exdent = 2L)) |
| }) |
| } else character() |
| } |
| |
| ### * .check_Rd_xrefs |
| |
| .check_Rd_xrefs <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Build a db with all possible link targets (aliases) in the base |
| ## and recommended packages. |
| base <- unlist(.get_standard_package_names()[c("base", "recommended")], |
| use.names = FALSE) |
| ## May not have recommended packages |
| base <- base[dir.exists(file.path(.Library, base))] |
| aliases <- lapply(base, Rd_aliases, lib.loc = NULL) |
| ## (Don't use lib.loc = .Library, as recommended packages may have |
| ## been installed to a different place.) |
| |
| ## Now find the aliases in packages it depends on |
| if(!missing(package)) { |
| pfile <- system.file("Meta", "package.rds", package = package, |
| lib.loc = lib.loc) |
| pkgInfo <- readRDS(pfile) |
| } else { |
| outDir <- file.path(tempdir(), "fake_pkg") |
| dir.create(file.path(outDir, "Meta"), FALSE, TRUE) |
| .install_package_description(dir, outDir) |
| pfile <- file.path(outDir, "Meta", "package.rds") |
| pkgInfo <- readRDS(pfile) |
| unlink(outDir, recursive = TRUE) |
| } |
| ## only 'Depends' are guaranteed to be on the search path, but |
| ## 'Imports' have to be installed and hence help there will be found |
| deps <- c(names(pkgInfo$Depends), names(pkgInfo$Imports)) |
| pkgs <- setdiff(unique(deps), base) |
| try_Rd_aliases <- function(...) tryCatch(Rd_aliases(...), error = identity) |
| aliases <- c(aliases, lapply(pkgs, try_Rd_aliases, lib.loc = lib.loc)) |
| aliases[vapply(aliases, inherits, "error", FUN.VALUE = NA)] <- NULL |
| |
| ## Add the aliases from the package itself, and build a db with all |
| ## (if any) \link xrefs in the package Rd objects. |
| if(!missing(package)) { |
| aliases1 <- Rd_aliases(package, lib.loc = lib.loc) |
| if(!length(aliases1)) |
| return(structure(list(), class = "check_Rd_xrefs")) |
| aliases <- c(aliases, list(aliases1)) |
| db <- .build_Rd_xref_db(package, lib.loc = lib.loc) |
| } else { |
| aliases1 <- Rd_aliases(dir = dir) |
| if(!length(aliases1)) |
| return(structure(list(), class = "check_Rd_xrefs")) |
| aliases <- c(aliases, list(aliases1)) |
| db <- .build_Rd_xref_db(dir = dir) |
| } |
| |
| ## Flatten the xref db into one big matrix. |
| db <- cbind(do.call("rbind", db), |
| rep.int(names(db), vapply(db, NROW, 0L))) |
| if(nrow(db) == 0L) |
| return(structure(list(), class = "check_Rd_xrefs")) |
| |
| ## fixup \link[=dest] form |
| anchor <- db[, 2L] |
| have_equals <- startsWith(anchor, "=") |
| if(any(have_equals)) |
| db[have_equals, 1:2] <- cbind(sub("^=", "", anchor[have_equals]), "") |
| |
| db <- cbind(db, bad = FALSE, report = db[, 1L]) |
| have_anchor <- nzchar(anchor <- db[, 2L]) |
| db[have_anchor, "report"] <- |
| paste0("[", db[have_anchor, 2L], "]{", db[have_anchor, 1L], "}") |
| |
| ## Check the targets from the non-anchored xrefs. |
| db[!have_anchor, "bad"] <- db[!have_anchor, 1L] %notin% unlist(aliases) |
| |
| ## and then check the anchored ones if we can. |
| have_colon <- grepl(":", anchor, fixed = TRUE) |
| unknown <- character() |
| thispkg <- anchor |
| thisfile <- db[, 1L] |
| thispkg [have_colon] <- sub("([^:]*):(.*)", "\\1", anchor[have_colon]) |
| thisfile[have_colon] <- sub("([^:]*):(.*)", "\\2", anchor[have_colon]) |
| |
| use_aliases_from_CRAN <- |
| config_val_to_logical(Sys.getenv("_R_CHECK_XREFS_USE_ALIASES_FROM_CRAN_", |
| "FALSE")) |
| if(use_aliases_from_CRAN) { |
| aliases_db <- NULL |
| } |
| |
| for (pkg in unique(thispkg[have_anchor])) { |
| ## we can't do this on the current uninstalled package! |
| if (missing(package) && pkg == basename(dir)) next |
| this <- have_anchor & (thispkg %in% pkg) |
| top <- system.file(package = pkg, lib.loc = lib.loc) |
| if(nzchar(top)) { |
| RdDB <- file.path(top, "help", "paths.rds") |
| if(!file.exists(RdDB)) { |
| message(gettextf("package %s exists but was not installed under R >= 2.10.0 so xrefs cannot be checked", sQuote(pkg)), |
| domain = NA) |
| next |
| } |
| nm <- sub("\\.[Rr]d", "", basename(readRDS(RdDB))) |
| good <- thisfile[this] %in% nm |
| suspect <- if(any(!good)) { |
| aliases1 <- if (pkg %in% names(aliases)) aliases[[pkg]] |
| else Rd_aliases(pkg, lib.loc = lib.loc) |
| !good & (thisfile[this] %in% aliases1) |
| } else FALSE |
| db[this, "bad"] <- !good & !suspect |
| } else if(use_aliases_from_CRAN) { |
| if(is.null(aliases_db)) { |
| ## Not yet read in. |
| aliases_db <- CRAN_aliases_db() |
| } |
| aliases <- aliases_db[[pkg]] |
| if(is.null(aliases)) { |
| unknown <- c(unknown, pkg) |
| next |
| } |
| ## message(sprintf("Using aliases db for package %s", pkg)) |
| nm <- sub("\\.[Rr]d", "", basename(names(aliases))) |
| good <- thisfile[this] %in% nm |
| suspect <- if(any(!good)) { |
| aliases1 <- unique(as.character(unlist(aliases, |
| use.names = |
| FALSE))) |
| !good & (thisfile[this] %in% aliases1) |
| } else FALSE |
| db[this, "bad"] <- !good & !suspect |
| } |
| else |
| unknown <- c(unknown, pkg) |
| } |
| |
| unknown <- unique(unknown) |
| obsolete <- unknown %in% c("ctest", "eda", "lqs", "mle", "modreg", "mva", "nls", "stepfun", "ts") |
| if (any(obsolete)) { |
| message(sprintf(ngettext(sum(obsolete), |
| "Obsolete package %s in Rd xrefs", |
| "Obsolete packages %s in Rd xrefs"), |
| paste(sQuote(unknown[obsolete]), collapse = ", ")), |
| domain = NA) |
| } |
| unknown <- unknown[!obsolete] |
| if (length(unknown)) { |
| repos <- .get_standard_repository_URLs() |
| ## Also allow for additionally specified repositories. |
| aurls <- pkgInfo[["DESCRIPTION"]]["Additional_repositories"] |
| if(!is.na(aurls)) { |
| repos <- c(repos, .read_additional_repositories_field(aurls)) |
| } |
| known <- |
| try(suppressWarnings(utils::available.packages(utils::contrib.url(repos, "source"), |
| filters = c("R_version", "duplicates"))[, "Package"])) |
| miss <- if(inherits(known, "try-error")) TRUE |
| else unknown %in% c(known, c("GLMMGibbs", "survnnet", "yags")) |
| ## from CRANextras |
| if(any(miss)) |
| message(sprintf(ngettext(sum(miss), |
| "Package unavailable to check Rd xrefs: %s", |
| "Packages unavailable to check Rd xrefs: %s"), |
| paste(sQuote(unknown[miss]), collapse = ", ")), |
| domain = NA) |
| if(any(!miss)) |
| message(sprintf(ngettext(sum(!miss), |
| "Unknown package %s in Rd xrefs", |
| "Unknown packages %s in Rd xrefs"), |
| paste(sQuote(unknown[!miss]), collapse = ", ")), |
| domain = NA) |
| } |
| ## The bad ones: |
| bad <- db[, "bad"] == "TRUE" |
| res1 <- split(db[bad, "report"], db[bad, 3L]) |
| structure(list(bad = res1), class = "check_Rd_xrefs") |
| } |
| |
| format.check_Rd_xrefs <- |
| function(x, ...) |
| { |
| xx <- x$bad |
| if(length(xx)) { |
| .fmt <- function(i) { |
| c(gettextf("Missing link or links in documentation object '%s':", |
| names(xx)[i]), |
| ## NB, link might be empty, and was in mvbutils |
| .pretty_format(unique(xx[[i]])), |
| "") |
| } |
| c(unlist(lapply(seq_along(xx), .fmt)), |
| strwrap(gettextf("See section 'Cross-references' in the 'Writing R Extensions' manual.")), |
| "") |
| } else { |
| character() |
| } |
| } |
| |
| ### * .check_package_datasets |
| |
| .check_package_datasets <- |
| function(pkgDir) |
| { |
| Sys.setlocale("LC_CTYPE", "C") |
| options(warn=-1) |
| check_one <- function(x, ds) |
| { |
| if(!length(x)) return() |
| ## avoid as.list methods |
| if(is.list(x)) lapply(unclass(x), check_one, ds = ds) |
| if(is.character(x)) { |
| xx <- unclass(x) |
| enc <- Encoding(xx) |
| latin1 <<- latin1 + sum(enc == "latin1") |
| utf8 <<- utf8 + sum(enc == "UTF-8") |
| bytes <<- bytes + sum(enc == "bytes") |
| unk <- xx[enc == "unknown"] |
| ind <- .Call(C_check_nonASCII2, unk) |
| if(length(ind)) { |
| non_ASCII <<- c(non_ASCII, unk[ind]) |
| where <<- c(where, rep.int(ds, length(ind))) |
| } |
| } |
| a <- attributes(x) |
| if(!is.null(a)) { |
| lapply(a, check_one, ds = ds) |
| check_one(names(a), ds) |
| } |
| invisible() |
| } |
| |
| sink(tempfile()) ## suppress startup messages to stdout |
| on.exit(sink()) |
| files <- list_files_with_type(file.path(pkgDir, "data"), "data") |
| files <- unique(basename(file_path_sans_ext(files))) |
| ans <- vector("list", length(files)) |
| dataEnv <- new.env(hash=TRUE) |
| names(ans) <- files |
| old <- setwd(pkgDir) |
| |
| ## formerly used .try_quietly which stops on error |
| .try <- function (expr, msg) { |
| oop <- options(warn = 1) |
| on.exit(options(oop)) |
| outConn <- file(open = "w+") |
| sink(outConn, type = "output") |
| sink(outConn, type = "message") |
| yy <- tryCatch(withRestarts(withCallingHandlers(expr, error = { |
| function(e) invokeRestart("grmbl", e, sys.calls()) |
| }), grmbl = function(e, calls) { |
| n <- length(sys.calls()) |
| calls <- calls[-seq.int(length.out = n - 1L)] |
| calls <- rev(calls)[-c(1L, 2L)] |
| tb <- lapply(calls, deparse) |
| message(msg, conditionMessage(e), "\nCall sequence:\n", |
| paste(c(utils::head(.eval_with_capture(traceback(tb))$output, 5), |
| " ..."), |
| collapse = "\n"), |
| "\n") |
| }), error = identity, finally = { |
| sink(type = "message") |
| sink(type = "output") |
| close(outConn) |
| }) |
| } |
| |
| for(f in files) { |
| msg <- sprintf("Error loading dataset %s: ", sQuote(f)) |
| .try(utils::data(list = f, package = character(), envir = dataEnv), msg) |
| } |
| setwd(old) |
| |
| non_ASCII <- where <- character() |
| latin1 <- utf8 <- bytes <- 0L |
| ## avoid messages about loading packages that started with r48409 |
| ## (and some more ...) |
| ## aadd try() to ensure that all datasets are looked at |
| ## (if not all of each dataset). |
| for(ds in ls(envir = dataEnv, all.names = TRUE)) { |
| if(inherits(suppressMessages(try(check_one(get(ds, envir = dataEnv), ds), silent = TRUE)), |
| "try-error")) { |
| msg <- sprintf("Error loading dataset %s:\n ", sQuote(ds)) |
| message(msg, geterrmessage()) |
| } |
| } |
| unknown <- unique(cbind(non_ASCII, where)) |
| structure(list(latin1 = latin1, utf8 = utf8, bytes = bytes, |
| unknown = unknown), |
| class = "check_package_datasets") |
| } |
| |
| format.check_package_datasets <- |
| function(x, ...) |
| { |
| ## not sQuote as we have mucked about with locales. |
| iconv0 <- function(x, ...) paste0("'", iconv(x, ...), "'") |
| |
| suppress_notes <- |
| config_val_to_logical(Sys.getenv("_R_CHECK_PACKAGE_DATASETS_SUPPRESS_NOTES_", |
| "FALSE")) |
| |
| c(character(), |
| if((n <- x$latin1) && !suppress_notes) { |
| sprintf( |
| ngettext(n, |
| "Note: found %d marked Latin-1 string", |
| "Note: found %d marked Latin-1 strings"), n) |
| }, |
| if((n <- x$utf8) && !suppress_notes) { |
| sprintf( |
| ngettext(n, |
| "Note: found %d marked UTF-8 string", |
| "Note: found %d marked UTF-8 strings"), n) |
| }, |
| if((n <- x$bytes) && !suppress_notes) { |
| sprintf( |
| ngettext(n, |
| "Note: found %d string marked as \"bytes\"", |
| "Note: found %d strings marked as \"bytes\""), n) |
| }, |
| if(nr <- nrow(x$unknown)) { |
| msg <- ngettext(nr, |
| "Warning: found non-ASCII string", |
| "Warning: found non-ASCII strings", |
| domain = NA) |
| c(msg, |
| paste0(iconv0(x$unknown[, 1L], "", "ASCII", sub = "byte"), |
| " in object '", x$unknown[, 2L], "'")) |
| }) |
| } |
| |
| ### * .check_package_datasets2 |
| |
| .check_package_datasets2 <- |
| function(fileName, pkgname) |
| { |
| oldSearch <- search() |
| dataEnv <- new.env(hash = TRUE); |
| utils::data(list = fileName, package = pkgname, envir = dataEnv); |
| if (!length((ls(dataEnv)))) message("No dataset created in 'envir'") |
| if (!identical(search(), oldSearch)) message("Search path was changed") |
| invisible(NULL) |
| } |
| |
| ### * .check_package_compact_datasets |
| |
| .check_package_compact_datasets <- |
| function(pkgDir, thorough = FALSE) |
| { |
| msg <- NULL |
| rdas <- checkRdaFiles(file.path(pkgDir, "data")) |
| row.names(rdas) <- basename(row.names(rdas)) |
| problems <- with(rdas, (ASCII | compress == "none") & (size > 1e5)) |
| if (any(rdas$compress %in% c("bzip2", "xz"))) { |
| OK <- FALSE |
| Rdeps <- .split_description(.read_description(file.path(pkgDir, "DESCRIPTION")))$Rdepends2 |
| for(dep in Rdeps) { |
| if(dep$op != '>=') next |
| if(dep$version >= package_version("2.10")) {OK <- TRUE; break;} |
| } |
| if(!OK) msg <- "Warning: package needs dependence on R (>= 2.10)" |
| } |
| if (sum(rdas$size) < 1e5 || # we don't report unless we get a 1e5 reduction |
| any(rdas$compress %in% c("bzip2", "xz"))) # assume already optimized |
| thorough <- FALSE |
| sizes <- improve <- NULL |
| if (thorough) { |
| files <- Sys.glob(c(file.path(pkgDir, "data", "*.rda"), |
| file.path(pkgDir, "data", "*.RData"))) |
| ## Exclude .RData, which this may or may not match |
| files <- files[!endsWith(files, "/.RData")] |
| if (length(files)) { |
| cpdir <- tempfile('cp') |
| dir.create(cpdir) |
| file.copy(files, cpdir) |
| resaveRdaFiles(cpdir) |
| rdas2 <- checkRdaFiles(cpdir) |
| row.names(rdas2) <- basename(row.names(rdas2)) |
| diff2 <- (rdas2$ASCII != rdas$ASCII) | (rdas2$compress != rdas$compress) |
| diff2 <- diff2 & (rdas$size > 1e4) & (rdas2$size < 0.9*rdas$size) |
| sizes <- c(sum(rdas$size), sum(rdas2$size)) |
| improve <- data.frame(old_size = rdas$size, |
| new_size = rdas2$size, |
| compress = rdas2$compress, |
| row.names = row.names(rdas))[diff2, ] |
| } |
| } |
| structure(list(rdas = rdas[problems, 1:3], msg = msg, |
| sizes = sizes, improve = improve), |
| class = "check_package_compact_datasets") |
| } |
| |
| print.check_package_compact_datasets <- |
| function(x, ...) |
| { |
| reformat <- function(x) { |
| xx <- paste0(x, "b") |
| ind1 <- (x >= 1024) |
| xx[ind1] <- sprintf("%.0fKb", x[ind1]/1024) |
| ind2 <- x >= 1024^2 |
| xx[ind2] <- sprintf("%.1fMb", x[ind2]/(1024^2)) |
| ind3 <- x >= 1024^3 |
| xx[ind3] <- sprintf("%.1fGb", x[ind3]/1024^3) |
| xx |
| } |
| if(nr <- nrow(x$rdas)) { |
| msg <- ngettext(nr, |
| "Warning: large data file saved inefficiently:", |
| "Warning: large data files saved inefficiently:", |
| domain = NA) |
| writeLines(msg) |
| rdas <- x$rdas |
| rdas$size <- reformat(rdas$size) |
| print(rdas) |
| } |
| if(!is.null(x$msg)) writeLines(x$msg) |
| if(!is.null(s <- x$sizes) && s[1L] - s[2L] > 1e5 # save at least 100Kb |
| && s[2L]/s[1L] < 0.9) { # and at least 10% |
| writeLines(c("", |
| "Note: significantly better compression could be obtained", |
| " by using R CMD build --resave-data")) |
| if(nrow(x$improve)) { |
| improve <- x$improve |
| improve$old_size <- reformat(improve$old_size) |
| improve$new_size <- reformat(improve$new_size) |
| print(improve) |
| } |
| } |
| invisible(x) |
| } |
| |
| ### * .check_package_compact_sysdata |
| |
| .check_package_compact_sysdata <- |
| function(pkgDir, thorough = FALSE) |
| { |
| msg <- NULL |
| files <- file.path(pkgDir, "R", "sysdata.rda") |
| rdas <- checkRdaFiles(files) |
| row.names(rdas) <- basename(row.names(rdas)) |
| problems <- with(rdas, (ASCII | compress == "none") & (size > 1e5)) |
| if (any(rdas$compress %in% c("bzip2", "xz"))) { |
| OK <- FALSE |
| Rdeps <- .split_description(.read_description(file.path(pkgDir, "DESCRIPTION")))$Rdepends2 |
| for(dep in Rdeps) { |
| if(dep$op != '>=') next |
| if(dep$version >= package_version("2.10")) {OK <- TRUE; break;} |
| } |
| if(!OK) msg <- "Warning: package needs dependence on R (>= 2.10)" |
| } |
| if (sum(rdas$size) < 1e5 || # we don't report unless we get a 1e5 reduction |
| any(rdas$compress %in% c("bzip2", "xz"))) # assume already optimized |
| thorough <- FALSE |
| if (thorough) { |
| cpdir <- tempfile('cp') |
| dir.create(cpdir) |
| file.copy(files, cpdir) |
| resaveRdaFiles(cpdir) |
| rdas2 <- checkRdaFiles(cpdir) |
| row.names(rdas2) <- basename(row.names(rdas2)) |
| diff2 <- (rdas2$ASCII != rdas$ASCII) | (rdas2$compress != rdas$compress) |
| diff2 <- diff2 & (rdas$size > 1e4) & (rdas2$size < 0.9*rdas$size) |
| sizes <- c(sum(rdas$size), sum(rdas2$size)) |
| improve <- data.frame(old_size = rdas$size, |
| new_size = rdas2$size, |
| compress = rdas2$compress, |
| row.names = row.names(rdas))[diff2, ] |
| } else sizes <- improve <- NULL |
| structure(list(rdas = rdas[problems, 1:3], msg = msg, |
| sizes = sizes, improve = improve), |
| class = "check_package_compact_datasets") |
| } |
| |
| |
| ### * .check_package_subdirs |
| |
| ## used by R CMD build |
| .check_package_subdirs <- |
| function(dir, doDelete = FALSE) |
| { |
| OS_subdirs <- c("unix", "windows") |
| |
| mydir <- function(dir) |
| { |
| d <- list.files(dir, all.files = TRUE, full.names = FALSE) |
| if(!length(d)) return(d) |
| if(basename(dir) %in% c("R", "man")) |
| for(os in OS_subdirs) { |
| os_dir <- file.path(dir, os) |
| if(dir.exists(os_dir)) |
| d <- c(d, |
| file.path(os, |
| list.files(os_dir, |
| all.files = TRUE, |
| full.names = FALSE))) |
| } |
| d[file_test("-f", file.path(dir, d))] |
| } |
| |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| |
| wrong_things <- list(R = character(), man = character(), |
| demo = character(), `inst/doc` = character()) |
| |
| code_dir <- file.path(dir, "R") |
| if(dir.exists(code_dir)) { |
| all_files <- mydir(code_dir) |
| ## Under Windows, need a Makefile.win for methods. |
| R_files <- c("sysdata.rda", "Makefile.win", |
| list_files_with_type(code_dir, "code", |
| full.names = FALSE, |
| OS_subdirs = OS_subdirs)) |
| wrong <- setdiff(all_files, R_files) |
| ## now configure might generate files in this directory |
| generated <- which(endsWith(wrong, ".in")) |
| if(length(generated)) wrong <- wrong[-generated] |
| if(length(wrong)) { |
| wrong_things$R <- wrong |
| if(doDelete) unlink(file.path(dir, "R", wrong)) |
| } |
| } |
| |
| man_dir <- file.path(dir, "man") |
| if(dir.exists(man_dir)) { |
| all_files <- mydir(man_dir) |
| man_files <- list_files_with_type(man_dir, "docs", |
| full.names = FALSE, |
| OS_subdirs = OS_subdirs) |
| wrong <- setdiff(all_files, man_files) |
| if(length(wrong)) { |
| wrong_things$man <- wrong |
| if(doDelete) unlink(file.path(dir, "man", wrong)) |
| } |
| } |
| |
| demo_dir <- file.path(dir, "demo") |
| if(dir.exists(demo_dir)) { |
| all_files <- mydir(demo_dir) |
| demo_files <- list_files_with_type(demo_dir, "demo", |
| full.names = FALSE) |
| wrong <- setdiff(all_files, c("00Index", demo_files)) |
| if(length(wrong)) { |
| wrong_things$demo <- wrong |
| if(doDelete) unlink(file.path(dir, "demo", wrong)) |
| } |
| } |
| |
| ## check installed vignette material |
| subdir <- file.path("inst", "doc") |
| vigns <- pkgVignettes(dir = dir, subdirs = subdir) |
| if (!is.null(vigns) && length(vigns$docs)) { |
| vignettes <- basename(vigns$docs) |
| |
| ## Add vignette output files, if they exist |
| tryCatch({ |
| vigns <- pkgVignettes(dir = dir, subdirs = subdir, output = TRUE) |
| vignettes <- c(vignettes, basename(vigns$outputs)) |
| }, error = function(ex) {}) |
| |
| ## 'the file names should start with an ASCII letter and be comprised |
| ## entirely of ASCII letters or digits or hyphen or underscore' |
| ## Do this in a locale-independent way. |
| OK <- grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz][ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789._-]+$", vignettes) |
| wrong <- vignettes |
| if(length(OK)) wrong <- wrong[-OK] |
| if(length(wrong)) wrong_things$`inst/doc` <- wrong |
| } |
| |
| class(wrong_things) <- "subdir_tests" |
| wrong_things |
| } |
| |
| format.subdir_tests <- |
| function(x, ...) |
| { |
| .fmt <- function(i) { |
| tag <- names(x)[i] |
| c(sprintf("Subdirectory '%s' contains invalid file names:", |
| tag), |
| .pretty_format(x[[i]])) |
| } |
| |
| as.character(unlist(lapply(which(lengths(x) > 0L), .fmt))) |
| } |
| |
| ### * .check_package_ASCII_code |
| |
| .check_package_ASCII_code <- |
| function(dir, respect_quotes = FALSE) |
| { |
| OS_subdirs <- c("unix", "windows") |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| |
| code_dir <- file.path(dir, "R") |
| wrong_things <- character() |
| if(dir.exists(code_dir)) { |
| R_files <- list_files_with_type(code_dir, "code", |
| full.names = FALSE, |
| OS_subdirs = OS_subdirs) |
| for(f in R_files) { |
| text <- readLines(file.path(code_dir, f), warn = FALSE) |
| if(.Call(C_check_nonASCII, text, !respect_quotes)) |
| wrong_things <- c(wrong_things, f) |
| } |
| } |
| if(length(wrong_things)) cat(wrong_things, sep = "\n") |
| invisible(wrong_things) |
| } |
| |
| ### * .check_package_code_syntax |
| |
| .check_package_code_syntax <- |
| function(dir) |
| { |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| dir_name <- basename(dir) |
| |
| dfile <- file.path(dirname(dir), "DESCRIPTION") |
| enc <- if(file.exists(dfile)) |
| .read_description(dfile)["Encoding"] else NA |
| |
| ## This was always run in the C locale < 2.5.0 |
| ## However, what chars are alphabetic depends on the locale, |
| ## so as from R 2.5.0 we try to set a locale. |
| ## Any package with no declared encoding should have only ASCII R code. |
| if(!is.na(enc)) { ## try to use the declared encoding |
| if(.Platform$OS.type == "windows") { |
| ## "C" is in fact "en", and there are no UTF-8 locales |
| switch(enc, |
| "latin2" = Sys.setlocale("LC_CTYPE", 'polish'), |
| Sys.setlocale("LC_CTYPE", "C") |
| ) |
| } else { |
| loc <- Sys.getenv("R_ENCODING_LOCALES", NA_character_) |
| if(!is.na(loc)) { |
| loc <- strsplit(strsplit(loc, ":")[[1L]], "=") |
| nm <- lapply(loc, "[[", 1L) |
| loc <- lapply(loc, "[[", 2L) |
| names(loc) <- nm |
| if(!is.null(l <- loc[[enc]])) |
| Sys.setlocale("LC_CTYPE", l) |
| else |
| Sys.setlocale("LC_CTYPE", "C") |
| |
| } else if(l10n_info()[["UTF-8"]]) { |
| ## the hope is that the conversion to UTF-8 works and |
| ## so we can validly test the code in the current locale. |
| } else { |
| ## these are the POSIX forms, but of course not all Unixen |
| ## abide by POSIX. These locales need not exist, but |
| ## do in glibc. |
| switch(enc, |
| "latin1" = Sys.setlocale("LC_CTYPE", "en_US"), |
| "utf-8" =, # not valid, but used |
| "UTF-8" = Sys.setlocale("LC_CTYPE", "en_US.UTF-8"), |
| "latin2" = Sys.setlocale("LC_CTYPE", "pl_PL"), |
| "latin9" = Sys.setlocale("LC_CTYPE", |
| "fr_FR.iso885915@euro"), |
| Sys.setlocale("LC_CTYPE", "C") |
| ) |
| } |
| } |
| } |
| |
| collect_parse_woes <- function(f) { |
| .error <- .warnings <- character() |
| file <- file.path(dir, f) |
| if(!is.na(enc) && |
| (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { |
| lines <- iconv(readLines(file, warn = FALSE), from = enc, to = "", |
| sub = "byte") |
| withCallingHandlers(tryCatch(parse(text = lines), |
| error = function(e) |
| .error <<- conditionMessage(e)), |
| warning = function(e) { |
| .warnings <<- c(.warnings, |
| conditionMessage(e)) |
| invokeRestart("muffleWarning") |
| }) |
| } else { |
| withCallingHandlers(tryCatch(parse(file), |
| error = function(e) |
| .error <<- conditionMessage(e)), |
| warning = function(e) { |
| .warnings <<- c(.warnings, |
| conditionMessage(e)) |
| invokeRestart("muffleWarning") |
| }) |
| } |
| ## (We show offending file paths starting with the base of the |
| ## given directory as this provides "nicer" output ...) |
| if(length(.error) || length(.warnings)) |
| list(File = file.path(dir_name, f), |
| Error = .error, Warnings = .warnings) |
| else |
| NULL |
| } |
| |
| out <- |
| lapply(list_files_with_type(dir, "code", full.names = FALSE, |
| OS_subdirs = c("unix", "windows")), |
| collect_parse_woes) |
| Sys.setlocale("LC_CTYPE", "C") |
| structure(out[lengths(out) > 0L], |
| class = "check_package_code_syntax") |
| } |
| |
| print.check_package_code_syntax <- |
| function(x, ...) |
| { |
| first <- TRUE |
| for(i in seq_along(x)) { |
| if(!first) writeLines("") else first <- FALSE |
| xi <- x[[i]] |
| if(length(xi$Error)) { |
| msg <- gsub("\n", "\n ", sub("[^:]*: *", "", xi$Error), |
| perl = TRUE, useBytes = TRUE) |
| writeLines(c(sprintf("Error in file '%s':", xi$File), |
| paste0(" ", msg))) |
| } |
| if(len <- length(xi$Warnings)) |
| writeLines(c(sprintf(ngettext(len, |
| "Warning in file %s:", |
| "Warnings in file %s:"), |
| sQuote(xi$File)), |
| paste0(" ", gsub("\n\n", "\n ", xi$Warnings, |
| perl = TRUE, useBytes = TRUE)))) |
| } |
| invisible(x) |
| } |
| |
| ### * .check_package_code_shlib |
| |
| .check_package_code_shlib <- |
| function(dir) |
| { |
| predicate <- function(e) { |
| ((length(e) > 1L) |
| && (length(x <- as.character(e[[1L]])) == 1L) |
| && (x %in% c("library.dynam", "library.dynam.unload")) |
| && (length(y <- e[[2L]]) == 1L) |
| && is.character(y) |
| && grepl("\\.(so|sl|dll)$", y)) |
| } |
| |
| x <- Filter(length, |
| .find_calls_in_package_code(dir, predicate, |
| recursive = TRUE)) |
| |
| ## Because we really only need this for calling from R CMD check, we |
| ## produce output here in case we found something. |
| if(length(x)) |
| writeLines(c(unlist(Map(.format_calls_in_file, x, names(x))), |
| "")) |
| ## (Could easily provide format() and print() methods ...) |
| |
| invisible(x) |
| } |
| |
| ### * .check_package_code_startup_functions |
| |
| .check_package_code_startup_functions <- |
| function(dir) |
| { |
| bad_call_names <- |
| unlist(.bad_call_names_in_startup_functions) |
| |
| .check_startup_function <- function(fcode, fname) { |
| out <- list() |
| nms <- names(fcode[[2L]]) |
| ## Check names of formals. |
| ## Allow anything containing ... (for now); otherwise, insist on |
| ## length two with names starting with lib and pkg, respectively. |
| if(is.na(match("...", nms)) && |
| ((length(nms) != 2L) || |
| any(substring(nms, 1L, 3L) != c("lib", "pkg")))) |
| out$bad_arg_names <- nms |
| ## Look at all calls (not only at top level). |
| calls <- .find_calls(fcode[[3L]], recursive = TRUE) |
| if(!length(calls)) return(out) |
| cnames <- .call_names(calls) |
| ## And pick the ones which should not be there ... |
| bcn <- bad_call_names |
| if(fname == ".onAttach") bcn <- c(bcn, "library.dynam") |
| if(fname == ".onLoad") bcn <- c(bcn, "packageStartupMessage") |
| ind <- (cnames %in% bcn) |
| if(any(ind)) { |
| calls <- calls[ind] |
| cnames <- cnames[ind] |
| ## Exclude library(help = ......) calls. |
| pos <- which(cnames == "library") |
| if(length(pos)) { |
| pos <- pos[vapply(calls[pos], |
| function(e) |
| any(names(e)[-1L] == "help"), |
| NA)] |
| ## Could also match.call(base::library, e) first ... |
| if(length(pos)) { |
| calls <- calls[-pos] |
| cnames <- cnames[-pos] |
| } |
| } |
| if(length(calls)) { |
| out$bad_calls <- |
| list(calls = calls, names = cnames) |
| } |
| } |
| out |
| } |
| |
| calls <- .find_calls_in_package_code(dir, |
| .worker = |
| .get_startup_function_calls_in_file) |
| FL <- unlist(lapply(calls, "[[", ".First.lib")) |
| calls <- Filter(length, |
| lapply(calls, |
| function(e) |
| Filter(length, |
| Map(.check_startup_function, |
| e, names(e))))) |
| if(length(FL)) attr(calls, ".First.lib") <- TRUE |
| class(calls) <- "check_package_code_startup_functions" |
| calls |
| } |
| |
| format.check_package_code_startup_functions <- |
| function(x, ...) |
| { |
| res <- if(!is.null(attr(x, ".First.lib"))) "NB: .First.lib is obsolete and will not be used in R >= 3.0.0" else character() |
| if(length(x)) { |
| |
| ## Flatten out doubly recursive list of functions within list of |
| ## files structure for computing summary messages. |
| y <- unlist(x, recursive = FALSE) |
| |
| has_bad_wrong_args <- |
| "bad_arg_names" %in% unlist(lapply(y, names)) |
| calls <- |
| unique(unlist(lapply(y, |
| function(e) e[["bad_calls"]][["names"]]))) |
| has_bad_calls_for_load <- |
| any(calls %in% .bad_call_names_in_startup_functions$load) |
| has_bad_calls_for_output <- |
| any(calls %in% .bad_call_names_in_startup_functions$output) |
| has_unsafe_calls <- |
| any(calls %in% .bad_call_names_in_startup_functions$unsafe) |
| |
| .fmt_entries_for_file <- function(e, f) { |
| c(gettextf("File %s:", sQuote(f)), |
| unlist(Map(.fmt_entries_for_function, e, names(e))), |
| "") |
| } |
| |
| .fmt_entries_for_function <- function(e, f) { |
| c(if(length(bad <- e[["bad_arg_names"]])) { |
| gettextf(" %s has wrong argument list %s", |
| f, sQuote(paste(bad, collapse = ", "))) |
| }, |
| if(length(bad <- e[["bad_calls"]])) { |
| c(gettextf(" %s calls:", f), |
| paste0(" ", |
| unlist(lapply(bad[["calls"]], function(e) |
| paste(deparse(e), collapse = ""))))) |
| }) |
| } |
| |
| res <- |
| c(res, |
| unlist(Map(.fmt_entries_for_file, x, names(x)), |
| use.names = FALSE), |
| if(has_bad_wrong_args) |
| strwrap(gettextf("Package startup functions should have two arguments with names starting with %s and %s, respectively.", |
| sQuote("lib"), sQuote("pkg")), |
| exdent = 2L), |
| if(has_bad_calls_for_load) |
| strwrap(gettextf("Package startup functions should not change the search path."), |
| exdent = 2L), |
| if(has_bad_calls_for_output) |
| strwrap(gettextf("Package startup functions should use %s to generate messages.", |
| sQuote("packageStartupMessage")), |
| exdent = 2L), |
| if(has_unsafe_calls) |
| strwrap(gettextf("Package startup functions should not call %s.", |
| sQuote("installed.packages")), |
| exdent = 2L), |
| gettextf("See section %s in '%s'.", |
| sQuote("Good practice"), "?.onAttach") |
| ) |
| } |
| res |
| } |
| |
| .bad_call_names_in_startup_functions <- |
| list(load = c("library", "require"), |
| output = c("cat", "message", "print", "writeLines"), |
| unsafe = c("installed.packages", "utils::installed.packages")) |
| |
| .get_startup_function_calls_in_file <- |
| function(file, encoding = NA) |
| { |
| exprs <- .parse_code_file(file, encoding) |
| |
| ## Use a custom gatherer rather than .find_calls() with a suitable |
| ## predicate so that we record the name of the startup function in |
| ## which the calls were found. |
| calls <- list() |
| for(e in exprs) { |
| if((length(e) > 2L) && |
| (is.name(x <- e[[1L]])) && |
| (as.character(x) %in% c("<-", "=")) && |
| (length(y <- as.character(e[[2L]])) == 1L) && |
| (y %in% c(".First.lib", ".onAttach", ".onLoad")) && |
| (is.call(z <- e[[3L]])) && |
| (as.character(z[[1L]]) == "function")) { |
| new <- list(z) |
| names(new) <- as.character(y) |
| calls <- c(calls, new) |
| } |
| } |
| calls |
| } |
| |
| .call_names <- |
| function(x) |
| as.character(sapply(x, function(e) deparse(e[[1L]]))) |
| |
| |
| ### * .check_package_code_unload_functions |
| |
| .check_package_code_unload_functions <- |
| function(dir) |
| { |
| bad_call_names <- "library.dynam.unload" |
| |
| .check_unload_function <- function(fcode, fname) { |
| out <- list() |
| nms <- names(fcode[[2L]]) |
| ## Check names of formals. |
| ## Allow anything containing ... (for now); otherwise, insist on |
| ## length one with names starting with lib. |
| if(is.na(match("...", nms)) && |
| (length(nms) != 1L || substring(nms, 1L, 3L) != "lib")) |
| out$bad_arg_names <- nms |
| ## Look at all calls (not only at top level). |
| calls <- .find_calls(fcode[[3L]], recursive = TRUE) |
| if(!length(calls)) return(out) |
| cnames <- .call_names(calls) |
| ## And pick the ones which should not be there ... |
| ind <- cnames %in% bad_call_names |
| if(any(ind)) |
| out$bad_calls <- list(calls = calls[ind], names = cnames[ind]) |
| out |
| } |
| |
| calls <- .find_calls_in_package_code(dir, |
| .worker = |
| .get_unload_function_calls_in_file) |
| LL <- unlist(lapply(calls, "[[", ".Last.lib")) |
| calls <- Filter(length, |
| lapply(calls, |
| function(e) |
| Filter(length, |
| Map(.check_unload_function, |
| e, names(e))))) |
| if(length(LL)) { |
| code_objs <- ".Last.lib" |
| nsInfo <- parseNamespaceFile(basename(dir), dirname(dir)) |
| OK <- intersect(code_objs, nsInfo$exports) |
| for(p in nsInfo$exportPatterns) |
| OK <- c(OK, grep(p, code_objs, value = TRUE)) |
| if(!length(OK)) attr(calls, ".Last.lib") <- TRUE |
| } |
| class(calls) <- "check_package_code_unload_functions" |
| calls |
| } |
| |
| format.check_package_code_unload_functions <- |
| function(x, ...) |
| { |
| res <- if(!is.null(attr(x, ".Last.lib"))) "NB: .Last.lib will not be used unless it is exported" else character() |
| if(length(x)) { |
| |
| ## Flatten out doubly recursive list of functions within list of |
| ## files structure for computing summary messages. |
| y <- unlist(x, recursive = FALSE) |
| |
| has_bad_wrong_args <- |
| "bad_arg_names" %in% unlist(lapply(y, names)) |
| ## calls <- |
| ## unique(unlist(lapply(y, |
| ## function(e) e[["bad_calls"]][["names"]]))) |
| .fmt_entries_for_file <- function(e, f) { |
| c(gettextf("File %s:", sQuote(f)), |
| unlist(Map(.fmt_entries_for_function, e, names(e))), |
| "") |
| } |
| |
| .fmt_entries_for_function <- function(e, f) { |
| c(if(length(bad <- e[["bad_arg_names"]])) { |
| gettextf(" %s has wrong argument list %s", |
| f, sQuote(paste(bad, collapse = ", "))) |
| }, |
| if(length(bad <- e[["bad_calls"]])) { |
| c(gettextf(" %s calls:", f), |
| paste0(" ", |
| unlist(lapply(bad[["calls"]], function(e) |
| paste(deparse(e), collapse = ""))))) |
| }) |
| } |
| |
| res <- |
| c(res, |
| unlist(Map(.fmt_entries_for_file, x, names(x)), |
| use.names = FALSE), |
| if(has_bad_wrong_args) |
| strwrap(gettextf("Package detach functions should have one argument with name starting with %s.", sQuote("lib")), |
| exdent = 2L), |
| if(length(call)) |
| strwrap(gettextf("Package detach functions should not call %s.", |
| sQuote("library.dynam.unload")), |
| exdent = 2L), |
| gettextf("See section %s in '%s'.", |
| sQuote("Good practice"), "?.Last.lib") |
| ) |
| } |
| res |
| } |
| |
| .get_unload_function_calls_in_file <- |
| function(file, encoding = NA) |
| { |
| exprs <- .parse_code_file(file, encoding) |
| |
| ## Use a custom gatherer rather than .find_calls() with a suitable |
| ## predicate so that we record the name of the unload function in |
| ## which the calls were found. |
| calls <- list() |
| for(e in exprs) { |
| if((length(e) > 2L) && |
| (is.name(x <- e[[1L]])) && |
| (as.character(x) %in% c("<-", "=")) && |
| (length(y <- as.character(e[[2L]])) == 1L) && |
| (y %in% c(".Last.lib", ".onDetach")) && |
| (is.call(z <- e[[3L]])) && |
| (as.character(z[[1L]]) == "function")) { |
| new <- list(z) |
| names(new) <- as.character(y) |
| calls <- c(calls, new) |
| } |
| } |
| calls |
| } |
| |
| ### * .check_package_code_tampers |
| |
| .check_package_code_tampers <- |
| function(dir) |
| { |
| dfile <- file.path(dir, "DESCRIPTION") |
| pkgname <- if(file.exists(dfile)) |
| .read_description(dfile)["Package"] else "" |
| |
| predicate <- function(e) { |
| if(length(e) <= 1L) return(FALSE) |
| if(as.character(e[[1L]])[1L] %in% "unlockBinding") { |
| e3 <- as.character(e[[3L]]) |
| if (e3[[1L]] == "asNamespace") e3 <- as.character(e[[3L]][[2L]]) |
| return(e3 != pkgname) |
| } |
| if((as.character(e[[1L]])[1L] %in% ".Internal") && |
| as.character(e[[2L]][[1L]]) == "unlockBinding") return(TRUE) |
| if(as.character(e[[1L]])[1L] %in% "assignInNamespace") { |
| e3 <- as.character(e[[4L]]) |
| if (e3 == "asNamespace") e3 <- as.character(e[[4L]][[2L]]) |
| return(e3 != pkgname) |
| } |
| FALSE |
| } |
| |
| x <- Filter(length, |
| .find_calls_in_package_code(dir, predicate, |
| recursive = TRUE)) |
| |
| ## Because we really only need this for calling from R CMD check, we |
| ## produce output here in case we found something. |
| if(length(x)) |
| writeLines(unlist(Map(.format_calls_in_file, x, names(x)))) |
| ## (Could easily provide format() and print() methods ...) |
| |
| invisible(x) |
| } |
| |
| ### * .check_package_code_assign_to_globalenv |
| |
| .check_package_code_assign_to_globalenv <- |
| function(dir) |
| { |
| predicate <- function(e) { |
| if(!is.call(e) || |
| (length(x <- as.character(e[[1L]])) != 1L) || |
| (x != "assign")) |
| return(FALSE) |
| e <- e[as.character(e) != "..."] |
| ## Capture assignments to global env unless to .Random.seed. |
| ## (This may fail for conditionalized code not meant for R |
| ## [e.g., argument 'where'].) |
| mc <- tryCatch(match.call(base::assign, e), error = identity) |
| if(inherits(mc, "error") || identical(mc$x, ".Random.seed")) |
| return(FALSE) |
| if(!is.null(env <- mc$envir) && |
| identical(tryCatch(eval(env), |
| error = identity), |
| globalenv())) |
| return(TRUE) |
| if(!is.null(pos <- mc$pos) && |
| identical(tryCatch(eval(call("as.environment", pos)), |
| error = identity), |
| globalenv())) |
| return(TRUE) |
| FALSE |
| } |
| |
| calls <- Filter(length, |
| .find_calls_in_package_code(dir, predicate, |
| recursive = TRUE)) |
| class(calls) <- "check_package_code_assign_to_globalenv" |
| calls |
| } |
| |
| format.check_package_code_assign_to_globalenv <- |
| function(x, ...) |
| { |
| if(!length(x)) return(character()) |
| |
| c("Found the following assignments to the global environment:", |
| unlist(Map(.format_calls_in_file, x, names(x)))) |
| } |
| |
| ### * .check_package_code_attach |
| |
| .check_package_code_attach <- |
| function(dir) |
| { |
| predicate <- function(e) |
| ((length(x <- as.character(e[[1L]])) == 1L) && |
| (x == "attach")) |
| |
| calls <- Filter(length, |
| .find_calls_in_package_code(dir, predicate, |
| recursive = TRUE)) |
| class(calls) <- "check_package_code_attach" |
| calls |
| } |
| |
| format.check_package_code_attach <- |
| function(x, ...) |
| { |
| if(!length(x)) return(character()) |
| |
| c("Found the following calls to attach():", |
| unlist(Map(.format_calls_in_file, x, names(x)))) |
| } |
| |
| ### * .check_package_code_data_into_globalenv |
| |
| .check_package_code_data_into_globalenv <- |
| function(dir) |
| { |
| predicate <- function(e) { |
| if(!is.call(e) || |
| (length(x <- as.character(e[[1L]])) != 1L) || |
| (x != "data")) |
| return(FALSE) |
| ## As data() has usage |
| ## data(..., list = character(), package = NULL, lib.loc = NULL, |
| ## verbose = getOption("verbose"), envir = .GlobalEnv)) |
| ## argument 'envir' must be matched exactly, and calls which |
| ## only have the last four arguments do not load any data. |
| env <- e$envir |
| tab <- c("package", "lib.loc", "verbose", "envir") |
| if(!is.null(nms <- names(e))) |
| e <- e[is.na(match(nms, tab))] |
| ((length(e) > 1L) && |
| (is.null(env) || |
| (is.name(env) && as.character(env) == ".GlobalEnv") || |
| (is.call(env) && as.character(env) == "globalenv"))) |
| } |
| |
| calls <- Filter(length, |
| .find_calls_in_package_code(dir, predicate, |
| recursive = TRUE)) |
| class(calls) <- "check_package_code_data_into_globalenv" |
| calls |
| } |
| |
| format.check_package_code_data_into_globalenv <- |
| function(x, ...) |
| { |
| if(!length(x)) return(character()) |
| |
| c("Found the following calls to data() loading into the global environment:", |
| unlist(Map(.format_calls_in_file, x, names(x)))) |
| } |
| |
| ### * .check_packages_used |
| |
| .check_packages_used <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Argument handling. |
| ns <- NULL |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in @code{dir} ... |
| code_dir <- file.path(dir, "R") |
| if(!dir.exists(code_dir)) |
| stop(gettextf("directory '%s' does not contain R code", |
| dir), |
| domain = NA) |
| if(basename(dir) != "base") |
| .load_package_quietly(package, lib.loc) |
| code_env <- if(packageHasNamespace(package, dirname(dir))) |
| asNamespace(package) |
| else |
| .package_env(package) |
| dfile <- file.path(dir, "DESCRIPTION") |
| db <- .read_description(dfile) |
| ## fake installs do not have this. |
| nsfile <- file.path(dir, "Meta", "nsInfo.rds") |
| if (file.exists(nsfile)) ns <- readRDS(nsfile) |
| else { |
| nsfile <- file.path(dir, "NAMESPACE") |
| if(file.exists(nsfile)) |
| ns <- parseNamespaceFile(basename(dir), dirname(dir)) |
| } |
| } |
| else if(!missing(dir)) { |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| dfile <- file.path(dir, "DESCRIPTION") |
| db <- .read_description(dfile) |
| nsfile <- file.path(dir, "NAMESPACE") |
| if(file.exists(nsfile)) |
| ns <- parseNamespaceFile(basename(dir), dirname(dir)) |
| code_dir <- file.path(dir, "R") |
| if(dir.exists(code_dir)) { |
| file <- tempfile() |
| on.exit(unlink(file)) |
| if(!file.create(file)) stop("unable to create ", file) |
| if(!all(.file_append_ensuring_LFs(file, |
| list_files_with_type(code_dir, |
| "code")))) |
| stop("unable to write code files") |
| } else return(invisible()) |
| } |
| pkg_name <- db["Package"] |
| depends <- .get_requires_from_package_db(db, "Depends") |
| imports <- imports0 <- .get_requires_from_package_db(db, "Imports") |
| suggests <- .get_requires_from_package_db(db, "Suggests") |
| enhances <- .get_requires_from_package_db(db, "Enhances") |
| |
| ## it is OK to refer to yourself and non-S4 standard packages |
| standard_package_names <- |
| setdiff(.get_standard_package_names()$base, |
| c("methods", "stats4")) |
| ## It helps to know if non-default standard packages are require()d |
| ## but safer to list them: compiler & parallel got included for years |
| ## Some people depend on 'base'! |
| default_package_names <- |
| c("base", "datasets", "grDevices", "graphics", "stats", "utils") |
| depends_suggests <- c(depends, suggests, enhances, pkg_name, default_package_names) |
| imports <- c(imports, depends, suggests, enhances, pkg_name, |
| standard_package_names) |
| ## the first argument could be named, or could be a variable name. |
| ## we just have a stop list here. |
| common_names <- c("pkg", "pkgName", "package", "pos", "dep_name") |
| |
| bad_exprs <- bad_deps <- bad_imps <- bad_prac <- character() |
| bad_imports <- all_imports <- imp2 <- imp2f <- imp3 <- imp3f <- character() |
| uses_methods <- FALSE |
| find_bad_exprs <- function(e) { |
| if(is.call(e) || is.expression(e)) { |
| Call <- deparse(e[[1L]])[1L] |
| if(Call %in% c("clusterEvalQ", "parallel::clusterEvalQ")) return() |
| if((Call %in% |
| c("library", "require", "loadNamespace", "requireNamespace")) |
| && (length(e) >= 2L)) { |
| ## We need to remove '...': OTOH the argument could be NULL |
| keep <- vapply(e, function(x) deparse(x)[1L] != "...", NA) |
| mc <- match.call(get(Call, baseenv()), e[keep]) |
| if(!is.null(pkg <- mc$package)) { |
| ## <NOTE> |
| ## Using code analysis, we really don't know which |
| ## package was called if character.only = TRUE and |
| ## the package argument is not a string constant. |
| ## (BTW, what if character.only is given a value |
| ## which is an expression evaluating to TRUE?) |
| dunno <- FALSE |
| if(isTRUE(mc$character.only) |
| && !identical(class(pkg), "character")) |
| dunno <- TRUE |
| ## </NOTE> |
| ## <FIXME> could be inside substitute or a variable |
| ## and is in e.g. R.oo |
| if(!dunno) { |
| if (Call %in% c("loadNamespace", "requireNamespace")) { |
| if (identical(class(pkg), "character")) { |
| pkg <- sub('^"(.*)"$', '\\1', deparse(pkg)) |
| if(! pkg %in% |
| c(imports, depends_suggests, common_names)) |
| bad_imps <<- c(bad_imps, pkg) |
| } |
| } else { |
| pkg <- sub('^"(.*)"$', '\\1', deparse(pkg)) |
| if(pkg %notin% c(depends_suggests, common_names)) |
| bad_exprs <<- c(bad_exprs, pkg) |
| if(pkg %in% depends) |
| bad_deps <<- c(bad_deps, pkg) |
| ## assume calls to itself are to clusterEvalQ etc |
| else if (pkg != pkg_name) |
| bad_prac <<- c(bad_prac, pkg) |
| } |
| } |
| } |
| } else if(Call %in% "::") { |
| pkg <- deparse(e[[2L]]) |
| all_imports <<- c(all_imports, pkg) |
| if(pkg %notin% imports) |
| bad_imports <<- c(bad_imports, pkg) |
| else { |
| imp2 <<- c(imp2, pkg) |
| imp2f <<- c(imp2f, deparse(e[[3L]])) |
| } |
| } else if(Call %in% ":::") { |
| pkg <- deparse(e[[2L]]) |
| all_imports <<- c(all_imports, pkg) |
| imp3 <<- c(imp3, pkg) |
| imp3f <<- c(imp3f, deparse(e[[3L]])) |
| if(pkg %notin% imports) |
| bad_imports <<- c(bad_imports, pkg) |
| } else if(Call %in% c("setClass", "setMethod")) { |
| uses_methods <<- TRUE |
| } |
| for(i in seq_along(e)) Recall(e[[i]]) |
| } |
| } |
| |
| if(!missing(package)) { |
| ## <FIXME> |
| ## Suggested way of checking for S4 metadata. |
| ## Change to use as envir_has_S4_metadata() once this makes it |
| ## into base or methods. |
| if(length(objects(code_env, all.names = TRUE, |
| pattern = "^[.]__[CT]_"))) |
| uses_methods <- TRUE |
| ## </FIXME> |
| exprs <- lapply(ls(envir = code_env, all.names = TRUE), |
| function(f) { |
| f <- get(f, envir = code_env) # get is expensive |
| if(typeof(f) == "closure") body(f) # else NULL |
| }) |
| if(.isMethodsDispatchOn()) { |
| ## Also check the code in S4 methods. |
| ## This may find things twice. |
| for(f in .get_S4_generics(code_env)) { |
| mlist <- .get_S4_methods_list(f, code_env) |
| exprs <- c(exprs, lapply(mlist, body)) |
| } |
| } |
| } |
| else { |
| enc <- db["Encoding"] |
| if(!is.na(enc) && |
| (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { |
| ## FIXME: what if conversion fails on e.g. UTF-8 comments |
| con <- file(file, encoding=enc) |
| on.exit(close(con)) |
| } else con <- file |
| exprs <- |
| tryCatch(parse(file = con, n = -1L), |
| error = function(e) |
| stop(gettextf("parse error in file '%s':\n%s", |
| file, |
| .massage_file_parse_error_message(conditionMessage(e))), |
| domain = NA, call. = FALSE)) |
| } |
| |
| for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]]) |
| |
| if(length(ns)) { |
| imp <- c(ns$imports, ns$importClasses, ns$importMethods) |
| if (length(imp)) { |
| imp <- sapply(imp, function(x) x[[1L]]) |
| all_imports <- unique(c(imp, all_imports)) |
| } |
| } else imp <- character() |
| bad_imp <- setdiff(imports0, all_imports) |
| |
| ## All the non-default packages need to be imported from. |
| depends_not_import <- setdiff(depends, c(imp, default_package_names)) |
| |
| methods_message <- |
| if(uses_methods && "methods" %notin% c(depends, imports)) |
| gettext("package 'methods' is used but not declared") |
| else "" |
| |
| extras <- list( |
| base = c("Sys.junction", "shell", "shell.exec"), |
| grDevices = c("X11.options", "X11Font", "X11Fonts", "quartz", |
| "quartz.options", "quartz.save", "quartzFont", "quartzFonts", |
| "bringToTop", "msgWindow", "win.graph", "win.metafile", "win.print", |
| "windows", "windows.options", "windowsFont", "windowsFonts"), |
| parallel = c("mccollect", "mcparallel", "mc.reset.stream", "mcaffinity"), |
| utils = c("nsl", "DLL.version", "Filters", |
| "choose.dir", "choose.files", "getClipboardFormats", |
| "getIdentification", "getWindowsHandle", "getWindowsHandles", |
| "getWindowTitle", "loadRconsole", "readClipboard", |
| "readRegistry", "setStatusBar", "setWindowTitle", |
| "shortPathName", "win.version", "winDialog", |
| "winDialogString", "winMenuAdd", "winMenuAddItem", |
| "winMenuDel", "winMenuDelItem", "winMenuNames", |
| "winMenuItems", "writeClipboard", "zip.unpack", |
| "winProgressBar", "getWinProgressBar", "setWinProgressBar", |
| "setInternet2", "arrangeWindows"), |
| RODBC = c("odbcConnectAccess", "odbcConnectAccess2007", |
| "odbcConnectDbase", "odbcConnectExcel", "odbcConnectExcel2007") |
| ) |
| imp2un <- character() |
| if(length(imp2)) { ## Try to check these are exported |
| names(imp2f) <- imp2 |
| imp2 <- unique(imp2) |
| imps <- split(imp2f, names(imp2f)) |
| for (p in names(imps)) { |
| ## some people have these quoted: |
| this <- imps[[p]] |
| this <- sub('^"(.*)"$', "\\1", this) |
| this <- sub("^'(.*)'$", "\\1", this) |
| if (p %in% "base") { |
| this <- setdiff(this, ls(baseenv(), all.names = TRUE)) |
| if(length(this)) |
| imp2un <- c(imp2un, paste(p, this, sep = "::")) |
| next |
| } |
| ns <- .getNamespace(p) |
| value <- if(is.null(ns)) { |
| ## this could be noisy |
| tryCatch(suppressWarnings(suppressMessages(loadNamespace(p))), |
| error = function(e) e) |
| } else NULL |
| if (!inherits(value, "error")) { |
| ns <- asNamespace(p) |
| exps <- c(ls(envir = .getNamespaceInfo(ns, "exports"), |
| all.names = TRUE), |
| ls(envir = .getNamespaceInfo(ns, "lazydata"), |
| all.names = TRUE), |
| extras[[p]]) |
| this2 <- setdiff(this, exps) |
| if(length(this2)) |
| imp2un <- c(imp2un, paste(p, this2, sep = "::")) |
| } |
| } |
| } |
| |
| names(imp3f) <- imp3 |
| ## Eliminate some methods ::: self-calls which we know are in fact |
| ## necessary. |
| if(pkg_name == "methods") { |
| imp3f <- imp3f[(imp3 != "methods") | |
| (imp3f %notin% c(".class1", |
| ".missingMethod", |
| ".selectDotsMethod", |
| ".setDummyField"))] |
| imp3 <- names(imp3f) |
| } |
| imp3 <- unique(imp3) |
| imp3self <- pkg_name %in% imp3 |
| imp3selfcalls <- as.vector(imp3f[names(imp3f) == pkg_name]) |
| imp3 <- setdiff(imp3, pkg_name) |
| if(length(imp3)) { |
| imp3f <- imp3f[names(imp3f) %in% imp3] |
| imps <- split(imp3f, names(imp3f)) |
| imp32 <- imp3 <- imp3f <- imp3ff <- unknown <- character() |
| for (p in names(imps)) { |
| this <- imps[[p]] |
| this <- sub('^"(.*)"$', "\\1", this) |
| this <- sub("^'(.*)'$", "\\1", this) |
| if (p %in% "base") { |
| imp32 <- c(imp32, paste(p, this, sep = ":::")) |
| next |
| } |
| ns <- .getNamespace(p) |
| value <- if(is.null(ns)) { |
| ## this could be noisy |
| tryCatch(suppressWarnings(suppressMessages(loadNamespace(p))), |
| error = function(e) e) |
| } else NULL |
| if (inherits(value, "error")) { |
| unknown <- c(unknown, p) |
| } else { |
| exps <- c(ls(envir = getNamespaceInfo(p, "exports"), |
| all.names = TRUE), extras[[p]]) |
| this2 <- this %in% exps |
| if (any(this2)) |
| imp32 <- c(imp32, paste(p, this[this2], sep = ":::")) |
| if (any(!this2)) { |
| imp3 <- c(imp3, p) |
| this <- this[!this2] |
| pp <- ls(envir = asNamespace(p), all.names = TRUE) |
| this2 <- this %in% pp |
| if(any(this2)) |
| imp3f <- c(imp3f, paste(p, this[this2], sep = ":::")) |
| if(any(!this2)) |
| imp3ff <- c(imp3ff, paste(p, this[!this2], sep = ":::")) |
| } |
| } |
| } |
| if(length(imp3f)) { |
| ## remove other packages which have the same maintainer, |
| ## but report references to itself. Unless they should be :: . |
| maintainers <- |
| sapply(strsplit(imp3f, ":::", fixed = TRUE), |
| function(p) { |
| dfile <- system.file("DESCRIPTION", package = p[[1L]]) |
| if(dfile == "") return("") |
| unname(.read_description(dfile)["Maintainer"]) |
| }) |
| imp3f <- imp3f[(maintainers != db["Maintainer"])] |
| } |
| } else imp32 <- imp3f <- imp3ff <- unknown <- character() |
| ## An unexported function only available on Windows, used in tools |
| imp3ff <- setdiff(sort(unique(imp3ff)), "utils:::unpackPkgZip") |
| res <- list(others = unique(bad_exprs), |
| bad_practice = unique(bad_prac), |
| imports = unique(bad_imports), |
| imps = unique(bad_imps), |
| in_depends = unique(bad_deps), |
| unused_imports = bad_imp, |
| depends_not_import = depends_not_import, |
| imp2un = sort(unique(imp2un)), |
| imp32 = sort(unique(imp32)), |
| imp3 = imp3, imp3f = sort(unique(imp3f)), |
| imp3ff = imp3ff, imp3self = imp3self, |
| imp3selfcalls = sort(unique(imp3selfcalls)), |
| imp3unknown = unknown, |
| methods_message = methods_message) |
| class(res) <- "check_packages_used" |
| res |
| } |
| |
| format.check_packages_used <- |
| function(x, ...) |
| { |
| incoming <- |
| identical(Sys.getenv("_R_CHECK_PACKAGES_USED_CRAN_INCOMING_NOTES_", |
| "FALSE"), |
| "TRUE") |
| ignore_unused_imports <- |
| config_val_to_logical(Sys.getenv("_R_CHECK_PACKAGES_USED_IGNORE_UNUSED_IMPORTS_", |
| "FALSE")) |
| |
| c(character(), |
| if(length(xx <- x$imports)) { |
| if(length(xx) > 1L) { |
| c(gettext("'::' or ':::' imports not declared from:"), |
| .pretty_format(sort(xx))) |
| } else { |
| gettextf("'::' or ':::' import not declared from: %s", sQuote(xx)) |
| } |
| }, |
| if(length(xx <- x$others)) { |
| if(length(xx) > 1L) { |
| c(gettext("'library' or 'require' calls not declared from:"), |
| .pretty_format(sort(xx))) |
| } else { |
| gettextf("'library' or 'require' call not declared from: %s", |
| sQuote(xx)) |
| } |
| }, |
| if(length(xx <- x$imps)) { |
| if(length(xx) > 1L) { |
| c(gettext("'loadNamespace' or 'requireNamespace' calls not declared from:"), |
| .pretty_format(sort(xx))) |
| } else { |
| gettextf("'loadNamespace' or 'requireNamespace' call not declared from: %s", |
| sQuote(xx)) |
| } |
| }, |
| if(length(xx <- x$in_depends)) { |
| msg <- " Please remove these calls from your code." |
| if(length(xx) > 1L) { |
| c(gettext("'library' or 'require' calls to packages already attached by Depends:"), |
| .pretty_format(sort(xx)), msg) |
| } else { |
| c(gettextf("'library' or 'require' call to %s which was already attached by Depends.", |
| sQuote(xx)), msg) |
| } |
| }, |
| if(length(xx <- x$bad_practice)) { |
| msg <- |
| " Please use :: or requireNamespace() instead.\n See section 'Suggested packages' in the 'Writing R Extensions' manual." |
| if(length(xx) > 1L) { |
| c(gettext("'library' or 'require' calls in package code:"), |
| .pretty_format(sort(xx)), msg) |
| } else { |
| c(gettextf("'library' or 'require' call to %s in package code.", |
| sQuote(xx)), msg) |
| } |
| }, |
| |
| if(length(xx <- x$unused_imports) && !ignore_unused_imports) { |
| msg <- " All declared Imports should be used." |
| if(length(xx) > 1L) { |
| c(gettext("Namespaces in Imports field not imported from:"), |
| .pretty_format(sort(xx)), msg) |
| } else { |
| c(gettextf("Namespace in Imports field not imported from: %s", |
| sQuote(xx)), msg) |
| } |
| }, |
| if(length(xx <- x$depends_not_import)) { |
| msg <- c(" These packages need to be imported from (in the NAMESPACE file)", |
| " for when this namespace is loaded but not attached.") |
| if(length(xx) > 1L) { |
| c(gettext("Packages in Depends field not imported from:"), |
| .pretty_format(sort(xx)), msg) |
| } else { |
| c(gettextf("Package in Depends field not imported from: %s", |
| sQuote(xx)), msg) |
| } |
| }, |
| if(length(xx <- x$imp2un)) { |
| if(length(xx) > 1L) { |
| c(gettext("Missing or unexported objects:"), |
| .pretty_format(sort(xx))) |
| } else { |
| gettextf("Missing or unexported object: %s", sQuote(xx)) |
| } |
| }, |
| if(length(xx <- x$imp32)) { ## ' ' seems to get converted to dir quotes |
| msg <- "See the note in ?`:::` about the use of this operator." |
| msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L) |
| if(length(xx) > 1L) { |
| c(gettext("':::' calls which should be '::':"), |
| .pretty_format(sort(xx)), msg) |
| } else { |
| c(gettextf("':::' call which should be '::': %s", |
| sQuote(xx)), msg) |
| } |
| }, |
| if(length(xx <- x$imp3ff)) { |
| if(length(xx) > 1L) { |
| c(gettext("Missing objects imported by ':::' calls:"), |
| .pretty_format(sort(xx))) |
| } else { |
| gettextf("Missing object imported by a ':::' call: %s", |
| sQuote(xx)) |
| } |
| }, |
| if(length(xxx <- x$imp3f)) { ## ' ' seems to get converted to dir quotes |
| msg <- "See the note in ?`:::` about the use of this operator." |
| msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L) |
| if(incoming) { |
| z <- sub(":::.*", "", xxx) |
| base <- unlist(.get_standard_package_names()[c("base", "recommended")]) |
| if (any(z %in% base)) |
| msg <- c(msg, |
| " Including base/recommended package(s):", |
| .pretty_format(intersect(base, z))) |
| } |
| if(length(xxx) > 1L) { |
| c(gettext("Unexported objects imported by ':::' calls:"), |
| .pretty_format(sort(xxx)), msg) |
| } else if(length(xxx)) { |
| c(gettextf("Unexported object imported by a ':::' call: %s", |
| sQuote(xxx)), msg) |
| } |
| }, |
| if(isTRUE(x$imp3self)) { |
| msg <- |
| c("There are ::: calls to the package's namespace in its code.", |
| "A package almost never needs to use ::: for its own objects:") |
| c(strwrap(paste(msg, collapse = " "), indent = 0L, exdent = 2L), |
| .pretty_format(sort(x$imp3selfcalls))) |
| }, |
| if(length(xx <- x$imp3unknown)) { |
| msg <- "See the note in ?`:::` about the use of this operator." |
| msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L) |
| if(length(xx) > 1L) { |
| c(gettext("Unavailable namespaces imported from by ':::' calls:"), |
| .pretty_format(sort(xx)), msg) |
| } else { |
| c(gettextf("Unavailable namespace imported from by a ':::' call: %s", |
| sQuote(xx)), msg) |
| } |
| }, |
| if(length(xx <- x$data)) { |
| if(length(xx) > 1L) { |
| c(gettext("'data(package=)' calls not declared from:"), |
| .pretty_format(sort(xx))) |
| } else { |
| gettextf("'data(package=)' call not declared from: %s", |
| sQuote(xx)) |
| } |
| }, |
| if(nzchar(x$methods_message)) { |
| x$methods_message |
| }) |
| } |
| |
| ### * .check_packages_used_in_examples |
| |
| .check_packages_used_helper <- |
| function(db, files) |
| { |
| pkg_name <- db["Package"] |
| depends <- .get_requires_from_package_db(db, "Depends") |
| imports <- .get_requires_from_package_db(db, "Imports") |
| suggests <- .get_requires_from_package_db(db, "Suggests") |
| enhances <- .get_requires_from_package_db(db, "Enhances") |
| |
| ## it is OK to refer to yourself and standard packages |
| standard_package_names <- .get_standard_package_names()$base |
| depends_suggests <- c(depends, imports, suggests, enhances, pkg_name, |
| standard_package_names) |
| ## the first argument could be named, or could be a variable name. |
| ## we just have a stop list here. |
| common_names <- c("pkg", "pkgName", "package", "pos") |
| |
| bad_exprs <- character() |
| bad_imports <- character() |
| bad_data <- character() |
| find_bad_exprs <- function(e) { |
| if(is.call(e) || is.expression(e)) { |
| Call <- deparse(e[[1L]])[1L] |
| if(length(e) >= 2L) pkg <- deparse(e[[2L]]) |
| if(Call %in% |
| c("library", "require", "loadNamespace", "requireNamespace")) { |
| if(length(e) >= 2L) { |
| ## We need to remove '...': OTOH the argument could be NULL |
| keep <- vapply(e, |
| function(x) deparse(x)[1L] != "...", |
| NA) |
| mc <- match.call(get(Call, baseenv()), e[keep]) |
| if(!is.null(pkg <- mc$package)) { |
| pkg <- sub('^"(.*)"$', '\\1', pkg) |
| ## <NOTE> |
| ## Using code analysis, we really don't know which |
| ## package was called if character.only = TRUE and |
| ## the package argument is not a string constant. |
| ## (Btw, what if character.only is given a value |
| ## which is an expression evaluating to TRUE?) |
| dunno <- FALSE |
| pos <- which(!is.na(pmatch(names(e), |
| "character.only"))) |
| if(length(pos) |
| && isTRUE(e[[pos]]) |
| && !identical(class(e[[2L]]), "character")) |
| dunno <- TRUE |
| ## </NOTE> |
| if(! dunno |
| && pkg %notin% c(depends_suggests, common_names)) |
| bad_exprs <<- c(bad_exprs, pkg) |
| } |
| } |
| } else if(Call %in% "::") { |
| if(! pkg %in% depends_suggests) |
| bad_imports <<- c(bad_imports, pkg) |
| } else if(Call %in% ":::") { |
| if(! pkg %in% depends_suggests) |
| bad_imports <<- c(bad_imports, pkg) |
| } else if((Call %in% "data" && length(e) >= 3L) || |
| (Call %in% c("utils::data", "utils:::data"))) { |
| mc <- match.call(utils::data, e) |
| if(is.character(pkg <- mc$package) && pkg %notin% depends_suggests) |
| bad_data <<- c(bad_data, pkg) |
| } |
| |
| for(i in seq_along(e)) Recall(e[[i]]) |
| } |
| } |
| |
| if (is.character(files)) { |
| for (f in files) { |
| tryCatch({ |
| ## This can give errors because the vignette etc |
| ## need not be in the session encoding. |
| exprs <- parse(file = f, n = -1L) |
| for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]]) |
| }, |
| error = function(e) { |
| ## so ignore 'invalid multibyte character' errors. |
| msg <- .massage_file_parse_error_message(conditionMessage(e)) |
| if(!startsWith(msg, "invalid multibyte character")) |
| warning(gettextf("parse error in file '%s':\n%s", |
| f, msg), |
| domain = NA, call. = FALSE) |
| }) |
| } |
| } else { |
| ## called for examples with translation |
| tryCatch({ |
| exprs <- parse(file = files, n = -1L) |
| for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]]) |
| }, |
| error = function(e) |
| warning(gettextf("parse error in file '%s':\n%s", |
| summary(files)$description, |
| .massage_file_parse_error_message(conditionMessage(e))), |
| domain = NA, call. = FALSE)) |
| } |
| |
| res <- list(others = unique(bad_exprs), |
| imports = unique(bad_imports), |
| data = unique(bad_data), |
| methods_message = "") |
| class(res) <- "check_packages_used" |
| res |
| } |
| |
| .check_packages_used_in_examples <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| dfile <- file.path(dir, "DESCRIPTION") |
| db <- .read_description(dfile) |
| } |
| else if(!missing(dir)) { |
| ## Using sources from directory @code{dir} ... |
| ## FIXME: not yet supported by .createExdotR. |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| dfile <- file.path(dir, "DESCRIPTION") |
| db <- .read_description(dfile) |
| } |
| pkg_name <- db["Package"] |
| |
| file <- .createExdotR(pkg_name, dir, silent = TRUE, |
| commentDonttest = FALSE) |
| if (is.null(file)) return(invisible(NULL)) # e.g, no examples |
| on.exit(unlink(file)) |
| enc <- db["Encoding"] |
| if(!is.na(enc) && |
| (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { |
| ## Avoid conversion failing on e.g. UTF-8 comments |
| ## con <- file(file, encoding = enc) |
| lines <- iconv(readLines(file, warn = FALSE), |
| from = "UTF-8", to = "", sub = "byte") |
| con <- textConnection(lines) |
| on.exit(close(con), add = TRUE) |
| } else con <- file |
| |
| .check_packages_used_helper(db, con) |
| } |
| |
| |
| ### * .check_packages_used_in_tests |
| |
| .check_packages_used_in_tests <- |
| function(dir, testdir, lib.loc = NULL) |
| { |
| ## Argument handling. |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| dfile <- file.path(dir, "DESCRIPTION") |
| db <- .read_description(dfile) |
| |
| testsrcdir <- file.path(dir, testdir) |
| od <- setwd(testsrcdir) |
| on.exit(setwd(od)) |
| Rinfiles <- list.files(".", pattern = "\\.Rin$") |
| Rfiles <- list.files(".", pattern = "\\.[rR]$") |
| if(testdir != "tests") { |
| use_subdirs <- FALSE |
| } else { |
| use_subdirs <- |
| Sys.getenv("_R_CHECK_PACKAGES_USED_IN_TESTS_USE_SUBDIRS_", |
| "FALSE") |
| use_subdirs <- config_val_to_logical(use_subdirs) |
| if(use_subdirs) { |
| subdirs <- c("testthat", "testit", "unitizer", "RUnit") |
| subdirs <- subdirs[dir.exists(subdirs)] |
| if(length(subdirs)) { |
| Rfiles <- |
| c(Rfiles, |
| unlist(lapply(subdirs, list.files, |
| pattern = "\\.[rR]$", |
| full.names = TRUE), |
| use.names = FALSE)) |
| } else { |
| use_subdirs <- FALSE |
| } |
| } |
| } |
| res <- .check_packages_used_helper(db, c(Rinfiles, Rfiles)) |
| if(use_subdirs && any(lengths(bad <- res[1L : 3L]))) { |
| ## Filter results against available package names to avoid (too |
| ## many) false positives. |
| ## <FIXME> |
| ## Should really standardize getting available packages when |
| ## checking. |
| repos <- .get_standard_repository_URLs() |
| available <- utils::available.packages(repos = repos) |
| res[1L : 3L] <- lapply(bad, intersect, available[, "Package"]) |
| } |
| res |
| } |
| |
| ### * .check_packages_used_in_vignettes |
| |
| .check_packages_used_in_vignettes <- |
| function(package, lib.loc = NULL) |
| { |
| ## Argument handling. |
| if(missing(package) || length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## FIXME: use Meta directory. |
| db <- .read_description(file.path(dir, "DESCRIPTION")) |
| vinfo <- pkgVignettes(dir = dir, subdirs = "doc", source = TRUE) |
| Rfiles <- unique(as.character(unlist(vinfo$sources))) |
| .check_packages_used_helper(db, Rfiles) |
| } |
| |
| ### * .check_T_and_F |
| |
| ## T and F checking, next generation. |
| ## |
| ## What are we really trying to do? |
| ## |
| ## In R, T and F are "just" variables which upon startup are bound to |
| ## TRUE and FALSE, respectively, in the base package/namespace. Hence, |
| ## if code uses "global" variables T and F and dynamic lookup is in |
| ## place (for packages, if they do not have a namespace), there may be |
| ## trouble in case T or F were redefined. So we'd like to warn about |
| ## these cases. |
| ## |
| ## A few things to note: |
| ## * Package code top-level bindings *to* T and F are not a problem for |
| ## packages installed for lazy-loading (as the top-level T and F get |
| ## evaluated "appropriately" upon installation. |
| ## * Code in examples using "global" T and F is always a problem, as |
| ## this is evaluated in the global envionment by examples(). |
| ## * There is no problem with package code using T and F as local |
| ## variables. |
| ## * Functions in a namespace will always find the T or F in the |
| ## namespace, imports or base, never in the global environment. |
| ## |
| ## Our current idea is the following. Function findGlobals() in |
| ## codetools already provides a way to (approximately) determine the |
| ## globals. So we can try to get these and report them. |
| ## |
| ## Note that findGlobals() only works on closures, so we definitely miss |
| ## top-level assignments to T or F. This could be taken care of rather |
| ## easily, though. |
| ## |
| ## Note also that we'd like to help people find where the offending |
| ## globals were found. Seems that codetools currently does not offer a |
| ## way of recording e.g. the parent expression, so we do our own thing |
| ## based on the legacy checkTnF code. |
| |
| .check_T_and_F <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Seems that checking examples has several problems, and can result |
| ## in "strange" diagnostic output. Let's more or less disable this |
| ## for the time being. |
| check_examples <- |
| isTRUE(as.logical(Sys.getenv("_R_CHECK_RD_EXAMPLES_T_AND_F_"))) |
| |
| |
| bad_closures <- character() |
| bad_examples <- character() |
| |
| find_bad_closures <- function(env) { |
| objects_in_env <- sort(names(env)) |
| x <- lapply(as.list(env, all.names = TRUE, sorted = TRUE), |
| function(v) { |
| if (typeof(v) == "closure") |
| codetools::findGlobals(v) |
| }) |
| names(x)[vapply(x, function(s) any(s %in% c("T", "F")), NA)] |
| } |
| |
| find_bad_examples <- function(txts) { |
| env <- new.env(hash = TRUE) # might be many |
| x <- lapply(txts, |
| function(txt) { |
| tryCatch({ |
| eval(parse(text = |
| paste("FOO <- function() {", |
| paste(txt, collapse = "\n"), |
| "}", |
| collapse = "\n")), |
| env) |
| find_bad_closures(env) |
| }, |
| error = function(e) character()) |
| }) |
| names(txts)[lengths(x) > 0L] |
| } |
| |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| if((package != "base") |
| && !packageHasNamespace(package, dirname(dir))) { |
| .load_package_quietly(package, lib.loc) |
| code_env <- .package_env(package) |
| bad_closures <- find_bad_closures(code_env) |
| } |
| if(check_examples) |
| example_texts <- |
| .get_example_texts_from_example_dir(file.path(dir, "R-ex")) |
| } |
| else { |
| ## The dir case. |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(!packageHasNamespace(basename(dir), dirname(dir)) |
| && dir.exists(code_dir)) { |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| bad_closures <- find_bad_closures(code_env) |
| } |
| if(check_examples) |
| example_texts <- .get_example_texts_from_source_dir(dir) |
| } |
| |
| if(check_examples) |
| bad_examples <- find_bad_examples(example_texts) |
| |
| out <- list(bad_closures = bad_closures, |
| bad_examples = bad_examples) |
| class(out) <- "check_T_and_F" |
| out |
| } |
| |
| .get_example_texts_from_example_dir <- |
| function(dir) |
| { |
| if(!dir.exists(dir)) return(NULL) |
| files <- list_files_with_exts(dir, "R") |
| texts <- lapply(files, |
| function(f) paste(readLines(f, warn = FALSE), |
| collapse = "\n")) |
| names(texts) <- files |
| texts |
| } |
| |
| .get_example_texts_from_source_dir <- |
| function(dir) |
| { |
| if(!dir.exists(file.path(dir, "man"))) return(NULL) |
| sapply(Rd_db(dir = dir), .Rd_get_example_code) |
| } |
| |
| format.check_T_and_F <- |
| function(x, ...) |
| { |
| c(character(), |
| if(length(x$bad_closures)) { |
| msg <- ngettext(length(x$bad_closures), |
| "Found possibly global 'T' or 'F' in the following function:", |
| "Found possibly global 'T' or 'F' in the following functions:" |
| ) |
| c(strwrap(msg), |
| .pretty_format(x$bad_closures)) |
| }, |
| if(length(x$bad_examples)) { |
| msg <- ngettext(length(x$bad_examples), |
| "Found possibly global 'T' or 'F' in the examples of the following Rd file:", |
| "Found possibly global 'T' or 'F' in the examples of the following Rd files:" |
| ) |
| c(strwrap(msg), |
| paste0(" ", x$bad_examples)) |
| }) |
| } |
| |
| ### * .check_dotIntenal |
| |
| .check_dotInternal <- |
| function(package, dir, lib.loc = NULL, details = TRUE) |
| { |
| bad_closures <- character() |
| |
| find_bad_closures <- function(env) { |
| objects_in_env <- as.list(env, all.names = TRUE, sorted = TRUE) |
| x <- lapply(objects_in_env, |
| function(v) { |
| if (typeof(v) == "closure") |
| codetools::findGlobals(v) |
| }) |
| names(x)[vapply(x, function(s) any(s %in% ".Internal"), NA)] |
| } |
| |
| find_bad_S4methods <- function(env) { |
| gens <- .get_S4_generics(code_env) |
| x <- lapply(gens, function(f) { |
| tab <- get(methods:::.TableMetaName(f, attr(f, "package")), |
| envir = code_env) |
| ## The S4 'system' does **copy** base code into packages .... |
| any(unlist(eapply(tab, function(v) !inherits(v, "derivedDefaultMethod") && |
| any(codetools::findGlobals(v) %in% ".Internal")))) |
| }) |
| gens[unlist(x)] |
| } |
| |
| find_bad_refClasses <- function(refs) { |
| cl <- names(refs) |
| x <- lapply(refs, function(z) { |
| any(vapply(z, |
| function(v) |
| any(codetools::findGlobals(v) %in% |
| ".Internal"), |
| NA)) |
| }) |
| cl[unlist(x)] |
| } |
| |
| |
| bad_S4methods <- list() |
| bad_refs <- character() |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| if(package %notin% .get_standard_package_names()$base) { |
| .load_package_quietly(package, lib.loc) |
| code_env <- if(packageHasNamespace(package, dirname(dir))) |
| asNamespace(package) |
| else .package_env(package) |
| bad_closures <- find_bad_closures(code_env) |
| if(.isMethodsDispatchOn()) { |
| bad_S4methods <- find_bad_S4methods(code_env) |
| refs <- .get_ref_classes(code_env) |
| if(length(refs)) bad_refs <- find_bad_refClasses(refs) |
| } |
| } |
| } |
| else { |
| ## The dir case. |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(dir.exists(code_dir)) { |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| bad_closures <- find_bad_closures(code_env) |
| } |
| } |
| |
| internals <- character() |
| if (length(bad_closures) && details) { |
| lapply(bad_closures, function(o) { |
| v <- get(o, envir = code_env) |
| calls <- .find_calls(v, recursive = TRUE) |
| if(!length(calls)) return() |
| calls <- calls[.call_names(calls) == ".Internal"] |
| calls2 <- lapply(calls, "[", 2L) |
| calls3 <- |
| sapply(calls2, function(x) sub("\\(.*", "", deparse(x)[1L])) |
| internals <<- c(internals, calls3) |
| }) |
| } |
| out <- list(bad_closures = bad_closures, internals = internals, |
| bad_S4methods = bad_S4methods, bad_refs = bad_refs) |
| class(out) <- "check_dotInternal" |
| out |
| } |
| |
| format.check_dotInternal <- |
| function(x, ...) |
| { |
| out <- if(length(x$bad_closures)) { |
| msg <- ngettext(length(x$bad_closures), |
| "Found a .Internal call in the following function:", |
| "Found .Internal calls in the following functions:" |
| ) |
| out <- c(strwrap(msg), .pretty_format(x$bad_closures)) |
| if (length(unique(x$internals))) |
| out <- c(out, "with calls to .Internal functions", |
| .pretty_format(sort(unique(x$internals)))) |
| out |
| } else character() |
| if(length(x$bad_S4methods)) { |
| msg <- ngettext(length(x$bad_S4methods), |
| "Found a.Internal call in methods for the following S4 generic:", |
| "Found .Internal calls in methods for the following S4 generics:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$bad_S4methods)) |
| } |
| if(length(x$bad_refs)) { |
| msg <- ngettext(length(x$bad_refs), |
| "Found a .Internal call in methods for the following reference class:", |
| "Found .Internal calls in methods for the following reference classes:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$bad_refs)) |
| } |
| out |
| } |
| |
| ### * .check_namespace |
| |
| .check_namespace <- |
| function(dir) |
| { |
| dir <- file_path_as_absolute(dir) |
| invisible(tryCatch(parseNamespaceFile(basename(dir), dirname(dir)), |
| error = function(e) { |
| writeLines("Invalid NAMESPACE file, parsing gives:") |
| stop(e) |
| })) |
| } |
| |
| ### * .check_citation |
| |
| .check_citation <- |
| function(cfile, dir = NULL) |
| { |
| cfile <- file_path_as_absolute(cfile) |
| |
| if(!is.null(dir)) { |
| meta <- utils::packageDescription(basename(dir), dirname(dir)) |
| db <- .read_citation_quietly(cfile, meta) |
| if(inherits(db, "error")) { |
| msg <- conditionMessage(db) |
| call <- conditionCall(db) |
| if(is.null(call)) |
| msg <- c("Error: ", msg) |
| else |
| msg <- c("Error in ", deparse(call), ": ", msg) |
| writeLines(paste(msg, collapse = "")) |
| } |
| return(invisible()) |
| } |
| |
| meta <- if(basename(dir <- dirname(cfile)) == "inst") |
| as.list(.get_package_metadata(dirname(dir))) |
| else |
| NULL |
| |
| db <- tryCatch(suppressMessages(get_CITATION_entry_fields(cfile, |
| meta$Encoding)), |
| error = identity) |
| |
| if(inherits(db, "error")) { |
| writeLines(conditionMessage(db)) |
| return(invisible()) |
| } |
| |
| if(!NROW(db)) return(invisible()) |
| |
| bad <- Map(find_missing_required_BibTeX_fields, db$Entry, db$Fields, |
| USE.NAMES = FALSE) |
| ind <- vapply(bad, identical, NA_character_, FUN.VALUE = NA) |
| if(length(pos <- which(ind))) { |
| entries <- db$Entry[pos] |
| entries <- |
| ifelse(nchar(entries) < 20L, |
| entries, |
| paste(substring(entries, 1L, 20L), "[TRUNCATED]")) |
| writeLines(sprintf("entry %d: invalid type %s", |
| pos, sQuote(entries))) |
| } |
| pos <- which(!ind & (lengths(bad) > 0L)) |
| if(length(pos)) { |
| writeLines(strwrap(sprintf("entry %d (%s): missing required field(s) %s", |
| pos, |
| db$Entry[pos], |
| vapply(bad[pos], |
| function(s) |
| paste(sQuote(s), |
| collapse = ", "), |
| "")), |
| indent = 0L, exdent = 2L)) |
| } |
| } |
| |
| ### * .check_package_parseRd |
| |
| ## FIXME: could use dumped files, except for use of encoding = "ASCII" |
| .check_package_parseRd <- |
| function(dir, silent = FALSE, def_enc = FALSE, minlevel = -1) |
| { |
| if(file.exists(dfile <- file.path(dir, "DESCRIPTION"))) { |
| enc <- read.dcf(dfile)[1L, ]["Encoding"] |
| if(is.na(enc)) enc <- "ASCII" |
| else def_enc <- TRUE |
| } else enc <- "ASCII" |
| macros <- loadPkgRdMacros(dir) |
| ## UGLY! FIXME: add (something like) 'dir' as argument to checkRd() below! |
| oenv <- Sys.getenv("_R_RD_MACROS_PACKAGE_DIR_", unset = NA) |
| on.exit(if (!is.na(oenv)) Sys.setenv("_R_RD_MACROS_PACKAGE_DIR_" = oenv) |
| else Sys.unsetenv("_R_RD_MACROS_PACKAGE_DIR_")) |
| Sys.setenv("_R_RD_MACROS_PACKAGE_DIR_" = normalizePath(dir)) |
| |
| pg <- dir("man", pattern = "[.][Rd]d$", full.names = TRUE) |
| bad <- character() |
| for (f in pg) { |
| ## Kludge for now |
| if(basename(f) %in% c("iconv.Rd", "showNonASCII.Rd")) def_enc <- TRUE |
| ## FIXME: this may not work for no/fake install if the expressions |
| ## involve the package under check. |
| tmp <- tryCatch(suppressMessages(checkRd(f, encoding = enc, |
| def_enc = def_enc, |
| macros = macros, |
| stages = c("build", "install", "render"))), |
| error = identity) |
| if(inherits(tmp, "error")) { |
| bad <- c(bad, f) |
| if(!silent) message(geterrmessage()) |
| } else print(tmp, minlevel = minlevel) |
| } |
| if(length(bad)) bad <- sQuote(sub(".*/", "", bad)) |
| if(length(bad) > 1L) |
| cat("problems found in ", paste(bad, collapse=", "), "\n", sep = "") |
| else if(length(bad)) |
| cat("problem found in ", bad, "\n", sep = "") |
| invisible() |
| } |
| |
| |
| ### * .check_depdef |
| |
| .check_depdef <- |
| function(package, dir, lib.loc = NULL, WINDOWS = FALSE) |
| { |
| bad_depr <- c("plclust") |
| |
| bad_def <- c("La.eigen", "tetragamma", "pentagamma", |
| "package.description", "gammaCody", |
| "manglePackageName", ".readRDS", ".saveRDS", |
| "mem.limits", "trySilent", "traceOn", "traceOff", |
| "print.coefmat", "anovalist.lm", "lm.fit.null", |
| "lm.wfit.null", "glm.fit.null", "tkcmd", |
| "tkfile.tail", "tkfile.dir", "tkopen", "tkclose", |
| "tkputs", "tkread", "Rd_parse", "CRAN.packages", |
| "zip.file.extract", |
| "real", "as.real", "is.real", |
| ".find.package", ".path.package") |
| |
| ## X11 may not work on even a Unix-alike: it needs X support |
| ## (optional) at install time and and an X server at run time. |
| bad_dev <- c("quartz", "x11", "X11") |
| if(!WINDOWS) |
| bad_dev <- c(bad_dev, "windows", "win.graph", "win.metafile", "win.print") |
| |
| bad <- c(bad_depr, bad_def, bad_dev) |
| bad_closures <- character() |
| found <- character() |
| |
| find_bad_closures <- function(env) { |
| objects_in_env <- as.list(env, all.names = TRUE, sorted = TRUE) |
| x <- lapply(objects_in_env, |
| function(v) { |
| if (typeof(v) == "closure") |
| codetools::findGlobals(v) |
| }) |
| names(x)[vapply(x, |
| function(s) { |
| res <- any(s %in% bad) |
| if(res) found <<- c(found, s) |
| res |
| }, |
| NA)] |
| } |
| |
| find_bad_S4methods <- function(env) { |
| gens <- .get_S4_generics(code_env) |
| x <- lapply(gens, function(f) { |
| tab <- get(methods:::.TableMetaName(f, attr(f, "package")), |
| envir = code_env) |
| ## The S4 'system' does **copy** base code into packages .... |
| any(unlist(eapply(tab, function(v) { |
| if(!inherits(v, "derivedDefaultMethod")) FALSE |
| else { |
| s <- codetools::findGlobals(v) |
| found <<- c(found, s) |
| any(s %in% bad) |
| } |
| }))) |
| }) |
| gens[unlist(x)] |
| } |
| |
| find_bad_refClasses <- function(refs) { |
| cl <- names(refs) |
| x <- lapply(refs, function(z) { |
| any(vapply(z, |
| function(v) { |
| s <- codetools::findGlobals(v) |
| found <<- c(found, s) |
| any(s %in% bad) |
| }, |
| NA)) |
| }) |
| cl[unlist(x)] |
| } |
| |
| |
| ## FIXME: these are set but not used. |
| bad_S4methods <- list() |
| bad_refs <- character() |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| if(package %notin% .get_standard_package_names()$base) { |
| .load_package_quietly(package, lib.loc) |
| code_env <- if(packageHasNamespace(package, dirname(dir))) |
| asNamespace(package) |
| else .package_env(package) |
| bad_closures <- find_bad_closures(code_env) |
| if(.isMethodsDispatchOn()) { |
| bad_S4methods <- find_bad_S4methods(code_env) |
| refs <- .get_ref_classes(code_env) |
| if(length(refs)) bad_refs <- find_bad_refClasses(refs) |
| } |
| } |
| } |
| else { |
| ## The dir case. |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| dir <- file_path_as_absolute(dir) |
| code_dir <- file.path(dir, "R") |
| if(dir.exists(code_dir)) { |
| code_env <- new.env(hash = TRUE) |
| dfile <- file.path(dir, "DESCRIPTION") |
| meta <- if(file_test("-f", dfile)) |
| .read_description(dfile) |
| else |
| character() |
| .source_assignments_in_code_dir(code_dir, code_env, meta) |
| bad_closures <- find_bad_closures(code_env) |
| } |
| } |
| |
| found <- sort(unique(found)) |
| deprecated <- found[found %in% bad_depr] |
| defunct <- found[found %in% bad_def] |
| devices <- found[found %in% bad_dev] |
| |
| out <- list(bad_closures = bad_closures, deprecated = deprecated, |
| defunct = defunct, devices = devices) |
| class(out) <- "check_depdef" |
| out |
| } |
| |
| format.check_depdef <- |
| function(x, ...) |
| { |
| out <- if(length(x$bad_closures)) { |
| msg <- ngettext(length(x$bad_closures), |
| "Found an obsolete/platform-specific call in the following function:", |
| "Found an obsolete/platform-specific call in the following functions:" |
| ) |
| c(strwrap(msg), .pretty_format(x$bad_closures)) |
| } else character() |
| if(length(x$bad_S4methods)) { |
| msg <- ngettext(length(x$bad_S4methods), |
| "Found an obsolete/platform-specific call in methods for the following S4 generic:", |
| "Found an obsolete/platform-specific call in methods for the following S4 generics:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$bad_S4methods)) |
| } |
| if(length(x$bad_refs)) { |
| msg <- ngettext(length(x$bad_refs), |
| "Found an obsolete/platform-specific call in methods for the following reference class:", |
| "Found an obsolete/platform-specific call in methods for the following reference classes:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$bad_refs)) |
| } |
| if(length(x$deprecated)) { |
| msg <- ngettext(length(x$deprecated), |
| "Found the deprecated function:", |
| "Found the deprecated functions:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$deprecated)) |
| } |
| if(length(x$defunct)) { |
| msg <- ngettext(length(x$defunct), |
| "Found the defunct/removed function:", |
| "Found the defunct/removed functions:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$defunct)) |
| } |
| if(length(x$devices)) { |
| msg <- ngettext(length(x$devices), |
| "Found the platform-specific device:", |
| "Found the platform-specific devices:" |
| ) |
| out <- c(out, strwrap(msg), .pretty_format(x$devices), |
| strwrap(paste("dev.new() is the preferred way to open a new device,", |
| "in the unlikely event one is needed.", |
| collapse = " "))) |
| } |
| out |
| } |
| |
| ### * .check_package_CRAN_incoming |
| |
| ## localOnly means to skip tests requiring Internet access. |
| ## These are all done first. |
| |
| .check_package_CRAN_incoming <- |
| function(dir, localOnly = FALSE) |
| { |
| out <- list() |
| class(out) <- "check_package_CRAN_incoming" |
| |
| meta <- .get_package_metadata(dir, FALSE) |
| lic_info <- analyze_license(meta["License"]) |
| ## Use later to indicate changes from FOSS to non-FOSS licence. |
| foss <- lic_info$is_verified |
| ## Record to notify about components extending a base license which |
| ## permits extensions. |
| if(length(extensions <- lic_info$extensions) && |
| ((length(components <- extensions$components) != 1L) || |
| (.license_component_is_for_stub_and_ok(components, |
| dir) != 0L)) && |
| any(ind <- extensions$extensible)) { |
| out$extensions <- extensions$components[ind] |
| out$pointers <- |
| Filter(length, |
| lapply(lic_info$pointers, |
| function(p) { |
| fp <- file.path(dir, p) |
| if(file_test("-f", fp)) { |
| lines <- readLines(fp, warn = FALSE) |
| ## Should this use the package |
| ## encoding? |
| ## (no, as we have LICENSE files with |
| ## copyright signs in ASCII packages) |
| pos <- grep("[^[:blank:]]", lines, |
| useBytes = TRUE) |
| c(p, if(len <- length(pos)) { |
| lines[seq.int(from = pos[1L], |
| to = pos[len])] |
| }) |
| } else NULL |
| })) |
| } |
| |
| out$Maintainer <- meta["Maintainer"] |
| ## pick out 'display name' |
| display <- gsub("<.*", "", as.vector(out$Maintainer)) |
| display <- sub("[[:space:]]+$", "", |
| sub("^[[:space:]]+", "", display, useBytes = TRUE), |
| useBytes = TRUE) |
| ## RFC 5322 allows '.' in the display name, but 2822 did not. |
| ## ',' separates email addresses. |
| out$Maintainer_needs_quotes <- |
| grepl("[,]", display, useBytes = TRUE) && !grepl('^".*"$', display, useBytes = TRUE) |
| out$empty_Maintainer_name <- !nzchar(display) |
| ## Try to catch bad maintainer fields which give more than one |
| ## person. In principle, the field should be of the form |
| ## DISPLAY-NAME <ANGLE-ADDR> |
| ## with the former (for simplicity) either a single quoted string, |
| ## or several atoms. (There are cases where <ANGLE-ADDR> does not |
| ## follow whitespace, so simple tokenizing via scan() does not quite |
| ## work.) |
| check_maintainer_address <- function(s) { |
| re <- paste0("^", |
| "[[:space:]]*", |
| "([^<]*|\"([^\"]|\\\\\")*\")", # display-name |
| "[[:space:]]*", |
| "(<[^>]+>)", # angle-addr |
| "[[:space:]]*", |
| "(.*)", # rest? |
| "[[:space:]]*", |
| "$") |
| s <- unlist(regmatches(s, regexec(re, s))) |
| length(s) && (s[5L] == "") ## && (s[2L] != "") |
| ## (Adding the test for s[2L] would check for non-empty |
| ## display-name which we already do separately.) |
| } |
| ## NOTE: perhaps whitespace should be canonicalized further above? |
| maintainer <- gsub("\n", " ", meta["Maintainer"]) |
| out$Maintainer_invalid_or_multi_person <- |
| ((maintainer != "ORPHANED") && |
| !check_maintainer_address(maintainer)) |
| |
| ver <- meta["Version"] |
| if(is.na(ver)) |
| stop("Package has no 'Version' field", call. = FALSE) |
| if(grepl("(^|[.-])0[0-9]+", ver)) |
| out$version_with_leading_zeroes <- ver |
| unlisted_version <- unlist(package_version(ver)) |
| if(any(unlisted_version >= 1234 & unlisted_version != as.integer(format(Sys.Date(), "%Y")))) |
| out$version_with_large_components <- ver |
| |
| .aspell_package_description_for_CRAN <- function(dir, meta = NULL) { |
| if(!is.null(meta)) { |
| dir.create(dir <- tempfile(pattern = "aspell")) |
| on.exit(unlink(dir, recursive = TRUE)) |
| .write_description(meta, file.path(dir, "DESCRIPTION")) |
| } |
| ignore <- |
| list(c("(?<=[ \t[:punct:]])'[^']*'(?=[ \t[:punct:]])", |
| "(?<=[ \t[:punct:]])([[:alnum:]]+::)?[[:alnum:]_.]*\\(\\)(?=[ \t[:punct:]])", |
| "(?<=[<])(https?://|DOI:|doi:|arXiv:)[^>]+(?=[>])"), |
| perl = TRUE) |
| utils:::aspell_package_description(dir, |
| ignore = ignore, |
| control = |
| c("--master=en_US", |
| "--add-extra-dicts=en_GB"), |
| program = "aspell", |
| dictionaries = "en_stats") |
| } |
| |
| language <- meta["Language"] |
| if((is.na(language) || language == "en") && |
| config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_USE_ASPELL_", |
| "FALSE"))) { |
| a <- .aspell_package_description_for_CRAN(dir) |
| if(NROW(a)) |
| out$spelling <- a |
| } |
| |
| parse_description_field <- function(desc, field, default) |
| str_parse_logic(desc[field], default=default) |
| |
| ## Check for possibly mis-spelled field names. |
| nms <- names(meta) |
| stdNms <- .get_standard_DESCRIPTION_fields() |
| nms <- nms[is.na(match(nms, stdNms)) & |
| !grepl(paste0("^(", |
| paste(c("X-CRAN", |
| "X-schema.org", |
| "Repository/R-Forge", |
| "VCS/", |
| "Config/"), |
| collapse = "|"), |
| ")"), |
| nms)] |
| if(length(nms) && ## Allow maintainer notes <stdName>Note : |
| length(nms <- nms[is.na(match(nms, paste0(stdNms,"Note")))])) |
| out$fields <- nms |
| |
| |
| uses <- character() |
| BUGS <- character() |
| for (field in c("Depends", "Imports", "Suggests")) { |
| p <- strsplit(meta[field], " *, *")[[1L]] |
| p2 <- grep("^(multicore|snow|igraph0|doSNOW)( |\\(|$)", p, value = TRUE) |
| uses <- c(uses, p2) |
| p2 <- grep("^(BRugs|R2OpenBUGS|R2WinBUGS)( |\\(|$)", p, value = TRUE) |
| BUGS <- c(BUGS, p2) |
| } |
| if (length(uses)) |
| out$uses <- sort(unique(gsub("[[:space:]]+", " ", uses))) |
| if (length(BUGS)) |
| out$BUGS <- sort(unique(gsub("[[:space:]]+", " ", BUGS))) |
| |
| ## Check for non-Sweave vignettes (as indicated by the presence of a |
| ## 'VignetteBuilder' field in DESCRIPTION) without |
| ## 'build/vignette.rds'. |
| |
| vds <- character() |
| if(!is.na(meta["VignetteBuilder"])) { |
| if(!file.exists(vds <- file.path(dir, "build", "vignette.rds"))) |
| out$missing_vignette_index <- TRUE |
| else |
| vds <- readRDS(vds)[, "File"] |
| } |
| |
| ## Check for missing build/{partial.rdb,pkgname.pdf} |
| ## copy code from build.R |
| Rdb <- .build_Rd_db(dir, stages = NULL, |
| os = c("unix", "windows"), step = 1) |
| if(length(Rdb)) { |
| names(Rdb) <- |
| substring(names(Rdb), nchar(file.path(dir, "man")) + 2L) |
| containsBuildSexprs <- |
| any(vapply(Rdb, |
| function(Rd) any(getDynamicFlags(Rd)["build"]), |
| NA)) |
| if(containsBuildSexprs && |
| !file.exists(file.path(dir, "build", "partial.rdb"))) |
| out$missing_manual_rdb <- TRUE |
| needRefMan <- |
| any(vapply(Rdb, |
| function(Rd) any(getDynamicFlags(Rd)[c("install", "render")]), |
| NA)) |
| if(needRefMan && |
| !file.exists(file.path(dir, "build", |
| paste0( meta[["Package"]], ".pdf")))) |
| out$missing_manual_pdf <- TRUE |
| } |
| |
| |
| ## Check for vignette source (only) in old-style 'inst/doc' rather |
| ## than 'vignettes'. |
| vign_dir <- file.path(dir, "vignettes") |
| if(length(vds)) { |
| sources <- setdiff(list.files(file.path(dir, "inst", "doc")), |
| list.files(vign_dir)) |
| sources <- intersect(vds, sources) |
| } else { |
| pattern <- vignetteEngine("Sweave")$pattern |
| sources <- setdiff(list.files(file.path(dir, "inst", "doc"), |
| pattern = pattern), |
| list.files(vign_dir, pattern = pattern)) |
| } |
| |
| if(length(sources)) { |
| out$have_vignettes_dir <- dir.exists(vign_dir) |
| out$vignette_sources_only_in_inst_doc <- sources |
| } |
| |
| ## Check for Java files without sources (in the right place) |
| ## NB: this is only a basic check: that directory need |
| ## not contain all (or any) of the sources. |
| ## We might in due course want to prompt looking into it. |
| if (foss && !dir.exists(file.path(dir, "java"))) { |
| allfiles <- list.files(file.path(dir, "inst"), |
| full.names = TRUE, recursive = TRUE) |
| allfiles <- c(allfiles, # misused by ndtv, sisus |
| list.files(file.path(dir, "exec"), full.names = TRUE)) |
| javafiles <- grep(".*[.](class|jar)$", allfiles, value = TRUE) |
| if(length(javafiles)) out$javafiles <- javafiles |
| } |
| |
| ## Check for installing Java source files |
| { |
| dotjava <- list.files(file.path(dir, "inst"), pattern = ".*[.]java$", |
| full.names = TRUE, recursive = TRUE) |
| dotjava <- c(dotjava, # misused by ndtv |
| list.files(file.path(dir, "exec"), pattern = ".*[.]java$", |
| full.names = TRUE)) |
| if(length(dotjava)) out$dotjava <- dotjava |
| } |
| |
| ## Check CITATION file for CRAN needs. |
| .check_citation_for_CRAN <- function(cfile, meta) { |
| ## For publishing on CRAN, we need to be able to correctly |
| ## process package CITATION files without having the package |
| ## installed (actually, using only the base and recommended |
| ## packages), which we cannot perfectly emulate when checking. |
| ## The best we can easily do is reduce the library search path |
| ## to the system and site library. If the package is not |
| ## installed there, check directly; otherwise, check for |
| ## offending calls likely to cause trouble. |
| ## Note however that in most cases, the issue is calling |
| ## packageDescription() to get the package metadata, instead of |
| ## using 'meta' as passed to readCitationFile() since R 2.8.0. |
| ## Unfortunately, when the package is not installed, |
| ## packageDescription() only warns and returns NA, or a vector |
| ## of NAs if called with specific fields. Subscripting the |
| ## return value using $ will fail (as this needs lists); |
| ## subscripting by other means, or using specific fields, |
| ## incorrectly results in NAs. |
| ## The warnings are currently not caught by the direct check. |
| ## (We could need a suitably package-not-found condition for |
| ## reliable analysis: the condition messages are locale |
| ## specific.) |
| libpaths <- .libPaths() |
| .libPaths(character()) |
| on.exit(.libPaths(libpaths)) |
| out <- list() |
| installed <- nzchar(system.file(package = meta["Package"])) |
| if(installed) { |
| ## Ignore pre-2.8.0 compatibility calls to |
| ## packageDescription() inside |
| ## if(!exists("meta") || is.null(meta)) |
| ccalls <- .parse_code_file(cfile, meta["Encoding"]) |
| ind <- vapply(ccalls, |
| function(e) { |
| is.call(e) && |
| (length(e) == 3L) && |
| identical(deparse(e[[1L]]), "if") && |
| identical(deparse(e[[2L]]), |
| "!exists(\"meta\") || is.null(meta)") |
| }, |
| NA) |
| if(any(ind)) |
| ccalls <- ccalls[!ind] |
| ccalls <- .find_calls(ccalls, recursive = TRUE) |
| cnames <- |
| intersect(unique(.call_names(ccalls)), |
| c("packageDescription", "library", "require")) |
| if(length(cnames)) |
| out$citation_calls <- cnames |
| cinfo <- |
| .eval_with_capture(tryCatch(utils::readCitationFile(cfile, |
| meta), |
| error = identity))$value |
| if(inherits(cinfo, "error")) { |
| out$citation_error_reading_if_installed <- |
| conditionMessage(cinfo) |
| return(out) |
| } |
| } else { |
| cinfo <- |
| .eval_with_capture(tryCatch(utils::readCitationFile(cfile, |
| meta), |
| error = identity))$value |
| if(inherits(cinfo, "error")) { |
| out$citation_error_reading_if_not_installed <- |
| conditionMessage(cinfo) |
| return(out) |
| } |
| } |
| ## If we can successfully read in the citation file, also check |
| ## whether we can at least format the bibentries we obtained. |
| cfmt <- tryCatch(format(cinfo, style = "text"), |
| warning = identity, error = identity) |
| ## This only finds unbalanced braces by default, with messages |
| ## unexpected END_OF_INPUT ... { no } |
| ## unexpected '}' ... } no { |
| ## One can also find 'unknown Rd macros' by setting env var |
| ## _R_UTILS_FORMAT_BIBENTRY_VIA_RD_PERMISSIVE_ to something |
| ## true, and perhaps we should do this here. |
| if(inherits(cfmt, "condition")) |
| out$citation_problem_when_formatting <- |
| conditionMessage(cfmt) |
| |
| out |
| } |
| if(file.exists(cfile <- file.path(dir, "inst", "CITATION"))) { |
| cinfo <- .check_citation_for_CRAN(cfile, meta) |
| if(length(cinfo)) |
| out[names(cinfo)] <- cinfo |
| ## Simply |
| ## out <- c(out, cinfo) |
| ## strips the class attribute from out ... |
| } |
| |
| ## Check Authors@R. |
| if(!is.na(aar <- meta["Authors@R"]) && |
| ## DESCRIPTION is fully checked later on, so be careful. |
| !inherits(aar <- tryCatch(parse(text = aar), error = identity), |
| "error")) { |
| bad <- ((length(aar) != 1L) || !is.call(aar <- aar[[1L]])) |
| if(!bad) { |
| cname <- as.character(aar[[1L]]) |
| bad <- |
| ((cname != "person") && |
| ((cname != "c") || |
| !all(vapply(aar[-1L], |
| function(e) { |
| (is.call(e) && |
| (as.character(e[[1L]]) == "person")) |
| }, |
| FALSE)))) |
| } |
| if(bad) |
| out$authors_at_R_calls <- aar |
| else { |
| ## Catch messages about deprecated arguments in person() calls. |
| aar <- meta["Authors@R"] |
| aut <- tryCatch(.eval_with_capture(utils:::.read_authors_at_R_field(aar)), |
| error = identity) |
| if(!inherits(aut, "error") && length(msg <- aut$message)) |
| out$authors_at_R_message <- msg |
| } |
| } |
| |
| ## Check Author field. |
| auth <- trimws(as.vector(meta["Author"])) |
| if(grepl("^Author *:", auth)) |
| out$author_starts_with_Author <- TRUE |
| if(grepl("^(Authors@R *:|person *\\(|c *\\()", auth)) |
| out$author_should_be_authors_at_R <- auth |
| |
| ## Check Title field. |
| title <- trimws(as.vector(meta["Title"])) |
| title <- gsub("[\n\t]", " ", title) |
| package <- meta["Package"] |
| if (tolower(title) == tolower(package)) { |
| out$title_is_name <- TRUE |
| } else { |
| if(grepl(paste0("^", |
| gsub(".", "[.]", package, fixed = TRUE), |
| "[ :]"), title, ignore.case = TRUE)) |
| out$title_includes_name <- TRUE |
| language <- meta["Language"] |
| if(is.na(language) || (language == "en")) { |
| title2 <- toTitleCase(title) |
| ## Keep single quoted elements unchanged. |
| p <- "(^|(?<=[ \t[:punct:]]))'[^']*'($|(?=[ \t[:punct:]]))" |
| m <- gregexpr(p, title, perl = TRUE) |
| regmatches(title2, m) <- regmatches(title, m) |
| if(title != title2) |
| out$title_case <- c(title, title2) |
| } |
| } |
| |
| ## Check Description field. |
| descr <- trimws(as.vector(meta["Description"])) |
| descr <- gsub("[\n\t]", " ", descr) |
| package <- meta["Package"] |
| if(grepl(paste0("^['\"]?", package), ignore.case = TRUE, descr)) |
| out$descr_bad_start <- TRUE |
| if(grepl("^(The|This|A|In this|In the) package", descr)) |
| out$descr_bad_start <- TRUE |
| if(!isTRUE(out$descr_bad_start) && !grepl("^['\"]?[[:upper:]]", descr)) |
| out$descr_bad_initial <- TRUE |
| descr <- strwrap(descr) |
| if(any(ind <- grepl("(^|[^<])https?://", descr))) { |
| ## Could try to filter out the matches for DOIs and arXiv ids |
| ## noted differently below: not entirely straightforward when |
| ## matching wrapped texts for to ease reporting ... |
| out$descr_bad_URLs <- descr[ind] |
| } |
| if(any(ind <- grepl("https?://.*doi.org/", descr))) |
| out$descr_bad_DOIs <- descr[ind] |
| if(any(ind <- grepl("https?://arxiv.org", descr))) |
| out$descr_bad_arXiv_ids <- descr[ind] |
| |
| skip_dates <- |
| config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_DATES_", |
| "FALSE")) |
| |
| ## Check Date |
| date <- trimws(as.vector(meta["Date"])) |
| if(!is.na(date)) { |
| dd <- strptime(date, "%Y-%m-%d", tz = "GMT") |
| if (is.na(dd)) out$bad_date <- TRUE |
| else if(!skip_dates && (as.Date(dd) < Sys.Date() - 31)) |
| out$old_date <- TRUE |
| } |
| |
| ## Check build time stamp |
| ptime <- trimws(as.vector(meta["Packaged"])) |
| if(is.na(ptime)) { |
| out$build_time_stamp_msg <- |
| "The build time stamp is missing." |
| } else { |
| ts <- strptime(ptime, "%Y-%m-%d", tz = "GMT") |
| if(is.na(ts)) { |
| out$build_time_stamp_msg <- |
| "The build time stamp has invalid/outdated format." |
| } |
| else if(!skip_dates && (as.Date(ts) < Sys.Date() - 31)) { |
| out$build_time_stamp_msg <- |
| "This build time stamp is over a month old." |
| } |
| } |
| |
| ## Are there non-ASCII characters in the R source code without a |
| ## package encoding in DESCRIPTION? |
| ## Note that checking always runs .check_package_ASCII_code() which |
| ## however ignores comments. Ideally, the checks would be merged, |
| ## with the comment checking suitably conditionalized. |
| ## Note also that this does not catch the cases where non-ASCII |
| ## content in R source code cannot be re-encoded using a given |
| ## package encoding. Ideally, this would be checked for as well. |
| if(is.na(meta["Encoding"]) && |
| dir.exists(code_dir <- file.path(dir, "R"))) { |
| ## A variation on showNonASCII(): |
| find_non_ASCII_lines <- function(f) { |
| x <- readLines(f, warn = FALSE) |
| asc <- iconv(x, "latin1", "ASCII") |
| ind <- is.na(asc) | asc != x |
| if(any(ind)) { |
| paste0(which(ind), |
| ": ", |
| iconv(x[ind], "latin1", "ASCII", sub = "byte")) |
| } else character() |
| } |
| OS_subdirs <- c("unix", "windows") |
| code_files <- list_files_with_type(file.path(dir, "R"), |
| "code", |
| OS_subdirs = OS_subdirs) |
| lines <- lapply(code_files, find_non_ASCII_lines) |
| names(lines) <- .file_path_relative_to_dir(code_files, dir) |
| lines <- Filter(length, lines) |
| if(length(lines)) |
| out$R_files_non_ASCII <- lines |
| } |
| |
| size <- Sys.getenv("_R_CHECK_SIZE_OF_TARBALL_", |
| unset = NA_character_) |
| if(!is.na(size) && (as.integer(size) > 5000000)) |
| out$size_of_tarball <- size |
| |
| ## Check URLs. |
| remote <- |
| (!localOnly && |
| !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_URL_CHECKS_IF_REMOTE_", |
| "FALSE"))) |
| if(!capabilities("libcurl") && remote) |
| out$no_url_checks <- TRUE |
| else { |
| bad <- tryCatch(check_url_db(url_db_from_package_sources(dir), |
| remote = remote), |
| error = identity) |
| if(inherits(bad, "error")) { |
| out$bad_urls <- bad |
| } else if(NROW(bad)) { |
| ## When checking a new submission, take the canonical CRAN |
| ## package URL as ok, and signal variants using http instead |
| ## of https as non-canonical instead of showing "not found". |
| prefix <- "https://cran.r-project.org/package=" |
| ncp <- nchar(prefix) |
| ind <- ((substring(tolower(bad$URL), 1L, ncp) == prefix) & |
| (substring(bad$URL, ncp + 1L) == package)) |
| if(any(ind)) |
| bad <- bad[!ind, ] |
| prefix <- "http://cran.r-project.org/package=" |
| ncp <- nchar(prefix) |
| ind <- ((substring(tolower(bad$URL), 1L, ncp) == prefix) & |
| (substring(bad$URL, ncp + 1L) == package)) |
| if(any(ind)) |
| bad[ind, c("Status", "Message")] <- "" |
| if(NROW(bad)) |
| out$bad_urls <- bad |
| } |
| } |
| |
| ## Checks from here down require Internet access, so drop out now if we |
| ## don't want that. |
| if (localOnly) |
| return(out) |
| |
| urls <- .get_standard_repository_URLs() |
| |
| ## If a package has a FOSS license, check whether any of its strong |
| ## recursive dependencies restricts use. |
| if(!localOnly && foss) { |
| available <- |
| utils::available.packages(utils::contrib.url(urls, "source"), |
| filters = |
| c("R_version", "duplicates")) |
| ## We need the current dependencies of the package (so batch |
| ## upload checks will not necessarily do "the right thing"). |
| package <- meta["Package"] |
| depends <- c("Depends", "Imports", "LinkingTo") |
| ## Need to be careful when merging the dependencies of the |
| ## package (in case it is not yet available). |
| if(!is.na(pos <- match(package, rownames(available)))) { |
| available[package, depends] <- meta[depends] |
| } else { |
| entry <- rbind(meta[colnames(available)]) |
| rownames(entry) <- package |
| available <- rbind(available, entry) |
| } |
| ldb <- analyze_licenses(available[, "License"], available) |
| depends <- unlist(package_dependencies(package, available, |
| recursive = TRUE)) |
| ru <- ldb$restricts_use |
| pnames_restricts_use_TRUE <- rownames(available)[!is.na(ru) & ru] |
| pnames_restricts_use_NA <- rownames(available)[is.na(ru)] |
| bad <- intersect(depends, pnames_restricts_use_TRUE) |
| if(length(bad)) |
| out$depends_with_restricts_use_TRUE <- bad |
| bad <- intersect(depends, pnames_restricts_use_NA) |
| if(length(bad)) |
| out$depends_with_restricts_use_NA <- bad |
| bv <- parse_description_field(meta, "BuildVignettes", TRUE) |
| if (!bv) out$foss_with_BuildVignettes <- TRUE |
| } |
| |
| ## We do not want to use utils::available.packages() for now, as |
| ## this unconditionally filters according to R version and OS type. |
| ## <FIXME> |
| ## This is no longer true ... |
| ## </FIXME> |
| .repository_db <- function(u) { |
| con <- gzcon(url(sprintf("%s/src/contrib/PACKAGES.gz", u), "rb")) |
| on.exit(close(con)) |
| ## hopefully all these fields are ASCII, or we need to re-encode. |
| cbind(read.dcf(con, |
| c(.get_standard_repository_db_fields(), "Path")), |
| Repository = u) |
| |
| } |
| db <- tryCatch(lapply(urls, .repository_db), error = identity) |
| if(inherits(db, "error")) { |
| message("NB: need Internet access to use CRAN incoming checks") |
| ## Actually, all repositories could be local file:// mirrors. |
| return(out) |
| } |
| db <- do.call(rbind, db) |
| |
| ## Note that .get_standard_repository_URLs() puts the CRAN master first. |
| CRAN <- urls[1L] |
| |
| ## Check for CRAN repository db overrides and possible conflicts. |
| con <- url(sprintf("%s/src/contrib/PACKAGES.in", CRAN)) |
| odb <- read.dcf(con) |
| close(con) |
| ## For now (2012-11-28), PACKAGES.in is all ASCII, so there is no |
| ## need to re-encode. Eventually, it might be in UTF-8 ... |
| entry <- odb[odb[, "Package"] == meta["Package"], ] |
| entry <- entry[!is.na(entry) & |
| (names(entry) %notin% c("Package", "X-CRAN-History"))] |
| if(length(entry)) { |
| ## Check for conflicts between package license implications and |
| ## repository overrides. Note that the license info predicates |
| ## are logicals (TRUE, NA or FALSE) and the repository overrides |
| ## are character ("yes", missing or "no"). |
| if(!is.na(iif <- lic_info$is_FOSS) && |
| !is.na(lif <- entry["License_is_FOSS"]) && |
| ((lif == "yes") != iif)) |
| out$conflict_in_license_is_FOSS <- lif |
| if(!is.na(iru <- lic_info$restricts_use) && |
| !is.na(lru <- entry["License_restricts_use"]) && |
| ((lru == "yes") != iru)) |
| out$conflict_in_license_restricts_use <- lru |
| |
| fmt <- function(s) |
| unlist(lapply(s, |
| function(e) { |
| paste(strwrap(e, indent = 2L, exdent = 4L), |
| collapse = "\n") |
| })) |
| nms <- names(entry) |
| ## Report all overrides for visual inspection. |
| entry <- fmt(sprintf(" %s: %s", nms, entry)) |
| names(entry) <- nms |
| out$overrides <- entry |
| fields <- intersect(names(meta), nms) |
| if(length(fields)) { |
| ## Find fields where package metadata and repository |
| ## overrides are in conflict. |
| ind <- ! unlist(Map(identical, |
| fmt(sprintf(" %s: %s", fields, meta[fields])), |
| entry[fields])) |
| if(any(ind)) |
| out$conflicts <- fields[ind] |
| } |
| } |
| |
| archive_db <- CRAN_archive_db() |
| packages_in_CRAN_archive <- names(archive_db) |
| |
| ## Package names must be unique within standard repositories when |
| ## ignoring case. |
| package <- meta["Package"] |
| packages <- db[, "Package"] |
| if(package %notin% packages) out$new_submission <- TRUE |
| clashes <- character() |
| pos <- which((tolower(packages) == tolower(package)) & |
| (packages != package)) |
| if(length(pos)) |
| clashes <- |
| sprintf("%s [%s]", packages[pos], db[pos, "Repository"]) |
| ## If possible, also catch clashes with archived CRAN packages |
| ## (which might get un-archived eventually). |
| if(length(packages_in_CRAN_archive)) { |
| pos <- which((tolower(packages_in_CRAN_archive) == |
| tolower(package)) & |
| (packages_in_CRAN_archive != package)) |
| if(length(pos)) { |
| clashes <- |
| c(clashes, |
| sprintf("%s [CRAN archive]", |
| packages_in_CRAN_archive[pos])) |
| } |
| } |
| if(length(clashes)) |
| out$bad_package <- list(package, clashes) |
| |
| ## Is this duplicated from another repository? |
| repositories <- db[(packages == package) & |
| (db[, "Repository"] != CRAN), |
| "Repository"] |
| if(length(repositories)) |
| out$repositories <- repositories |
| |
| ## Does this have strong dependencies not in mainstream |
| ## repositories? This should not happen, and hence is not compared |
| ## against possibly given additional repositories. |
| strong_dependencies <- |
| setdiff(unique(c(.extract_dependency_package_names(meta["Depends"]), |
| .extract_dependency_package_names(meta["Imports"]), |
| .extract_dependency_package_names(meta["LinkingTo"]))), |
| c(.get_standard_package_names()$base, db[, "Package"])) |
| if(length(strong_dependencies)) { |
| out$strong_dependencies_not_in_mainstream_repositories <- |
| strong_dependencies |
| } |
| |
| ## Does this have Suggests or Enhances not in mainstream |
| ## repositories? |
| suggests_or_enhances <- |
| setdiff(unique(c(.extract_dependency_package_names(meta["Suggests"]), |
| .extract_dependency_package_names(meta["Enhances"]))), |
| c(.get_standard_package_names()$base, db[, "Package"])) |
| if(length(suggests_or_enhances)) { |
| out$suggests_or_enhances_not_in_mainstream_repositories <- |
| suggests_or_enhances |
| } |
| if(!is.na(aurls <- meta["Additional_repositories"])) { |
| aurls <- .read_additional_repositories_field(aurls) |
| ## Get available packages separately for each given URL, so that |
| ## we can spot the ones which do not provide any packages. |
| adb <- |
| tryCatch(lapply(aurls, |
| function(u) { |
| utils::available.packages(utils::contrib.url(u, |
| "source"), |
| filters = |
| c("R_version", |
| "duplicates")) |
| }), |
| error = identity) |
| if(inherits(adb, "error")) { |
| out$additional_repositories_analysis_failed_with <- |
| conditionMessage(adb) |
| } else { |
| ## Check for additional repositories with no packages. |
| ind <- vapply(adb, NROW, 0L) == 0L |
| if(any(ind)) |
| out$additional_repositories_with_no_packages <- |
| aurls[ind] |
| ## Merge available packages dbs and remove duplicates. |
| adb <- do.call(rbind, adb) |
| adb <- utils:::available_packages_filters_db$duplicates(adb) |
| ## Ready. |
| dependencies <- unique(c(strong_dependencies, suggests_or_enhances)) |
| pos <- match(dependencies, rownames(adb), nomatch = 0L) |
| ind <- (pos > 0L) |
| tab <- matrix(character(), nrow = 0L, ncol = 3L) |
| if(any(ind)) |
| tab <- rbind(tab, |
| cbind(dependencies[ind], |
| "yes", |
| adb[pos[ind], "Repository"])) |
| ind <- !ind |
| if(any(ind)) |
| tab <- rbind(tab, |
| cbind(dependencies[ind], |
| "no", |
| "?")) |
| ## Map Repository fields to URLs, and determine unused |
| ## URLs. |
| ## Note that available.packages() possibly adds Path |
| ## information in the Repository field, so matching |
| ## given contrib URLs to these fields is not trivial. |
| unused <- character() |
| for(u in aurls) { |
| cu <- utils::contrib.url(u, "source") |
| ind <- startsWith(tab[, 3L], cu) |
| if(any(ind)) { |
| tab[ind, 3L] <- u |
| } else { |
| unused <- c(unused, u) |
| } |
| } |
| if(length(unused)) |
| tab <- rbind(tab, cbind("?", "?", unused)) |
| dimnames(tab) <- NULL |
| out$additional_repositories_analysis_results <- tab |
| } |
| } |
| |
| ## Check DOIs. |
| if(capabilities("libcurl") && |
| !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_DOI_CHECKS_", |
| "FALSE"))) { |
| bad <- tryCatch(check_doi_db(doi_db_from_package_sources(dir)), |
| error = identity) |
| if(inherits(bad, "error") || NROW(bad)) |
| out$bad_dois <- bad |
| } |
| |
| ## Is this an update for a package already on CRAN? |
| db <- db[(packages == package) & |
| (db[, "Repository"] == CRAN) & |
| is.na(db[, "Path"]), , drop = FALSE] |
| ## This drops packages in version-specific subdirectories. |
| ## It also does not know about archived versions. |
| if(!NROW(db)) { |
| if(package %in% packages_in_CRAN_archive) { |
| out$CRAN_archive <- TRUE |
| v_m <- package_version(meta["Version"]) |
| v_a <- sub("^.*_(.*)\\.tar.gz$", "\\1", |
| basename(rownames(archive_db[[package]]))) |
| v_a <- max(package_version(v_a, strict = FALSE), |
| na.rm = TRUE) |
| if(v_m <= v_a) |
| out$bad_version <- list(v_m, v_a) |
| } |
| if(!foss) |
| out$bad_license <- meta["License"] |
| return(out) |
| } |
| |
| ## Checks from this point down should be for a package already on CRAN |
| |
| ## For now, there should be no duplicates ... |
| |
| ## Package versions should be newer than what we already have on CRAN. |
| |
| v_m <- package_version(meta["Version"]) |
| v_d <- max(package_version(db[, "Version"])) |
| if((v_m <= v_d) && |
| !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_VERSIONS_", |
| "FALSE"))) |
| out$bad_version <- list(v_m, v_d) |
| if((v_m$major == v_d$major) & (v_m$minor >= v_d$minor + 10)) |
| out$version_with_jump_in_minor <- list(v_m, v_d) |
| |
| ## Check submission recency and frequency. |
| current_db <- CRAN_current_db() |
| mtimes <- c(current_db[match(package, |
| sub("_.*", "", |
| rownames(current_db)), |
| nomatch = 0L), |
| "mtime"], |
| archive_db[[package]]$mtime) |
| if(length(mtimes)) { |
| deltas <- Sys.Date() - as.Date(sort(mtimes, decreasing = TRUE)) |
| ## Number of days since last update. |
| recency <- as.numeric(deltas[1L]) |
| if(recency < 7) |
| out$recency <- recency |
| ## Number of updates in past 6 months. |
| frequency <- sum(deltas <= 180) |
| if(frequency > 6) |
| out$frequency <- frequency |
| } |
| |
| ## Watch out for maintainer changes. |
| ## Note that we cannot get the maintainer info from the PACKAGES |
| ## files. |
| db <- tryCatch(CRAN_package_db(), error = identity) |
| if(inherits(db, "error")) return(out) |
| |
| meta1 <- db[db[, "Package"] == package, ] |
| ## this can have multiple entries, e.g. for recommended packages. |
| meta0 <- unlist(meta1[1L, ]) |
| m_m <- as.vector(meta["Maintainer"]) # drop name |
| m_d <- meta0["Maintainer"] |
| # There may be white space differences here |
| m_m_1 <- gsub("[[:space:]]+", " ", m_m) |
| m_d_1 <- gsub("[[:space:]]+", " ", m_d) |
| if(!all(m_m_1 == m_d_1)) { |
| ## strwrap is used below, so we need to worry about encodings. |
| ## m_d is in UTF-8 already |
| if(Encoding(m_m) == "latin1") m_m <- iconv(m_m, "latin1") |
| out$new_maintainer <- list(m_m, m_d) |
| } |
| |
| l_d <- meta0["License"] |
| if(!foss && analyze_license(l_d)$is_verified) |
| out$new_license <- list(meta["License"], l_d) |
| |
| ## for incoming check we may want to check for GNU make in SystemRequirements here |
| ## in order to auto-accept packages once this was already accepted before |
| if(config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_NOTE_GNU_MAKE_", |
| "FALSE"))){ |
| SysReq <- meta["SystemRequirements"] |
| if(!is.na(SysReq) && grepl("GNU [Mm]ake", SysReq)) { |
| out$GNUmake <- TRUE |
| } |
| } |
| |
| ## Re-check for some notes if enabled and current version was published recently enough. |
| if(!inherits(year <- tryCatch(format(as.Date(meta0["Published"]), "%Y"), |
| error = identity), |
| "error")){ |
| ## possible mis-spellings and keep only the new ones: |
| if(NROW(a <- out$spelling) |
| && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_ASPELL_RECHECK_MAYBE_", |
| "TRUE")) |
| && (year >= |
| as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_ASPELL_RECHECK_START_", |
| "2013")))) { |
| a0 <- .aspell_package_description_for_CRAN(meta = meta0) |
| out$spelling <- a[is.na(match(a$Original, a0$Original)), ] |
| } |
| |
| # possible title_includes_name and only report if the title actually changed |
| if(NROW(out$title_includes_name) |
| && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_INCLUDES_NAME_RECHECK_MAYBE_", |
| "TRUE")) |
| && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_INCLUDES_NAME_RECHECK_START_", |
| "2016"))) |
| && meta0["Title"] == meta["Title"]) { |
| out$title_includes_name <- NULL |
| } |
| |
| # possible title case problems and only report if the title actually changed |
| if(NROW(out$title_case) |
| && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_CASE_RECHECK_MAYBE_", |
| "TRUE")) |
| && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_CASE_RECHECK_START_", |
| "2016"))) |
| && meta0["Title"] == meta["Title"]) { |
| out$title_case <- NULL |
| } |
| |
| # possible bad Description start and only report if new: |
| if(NROW(out$descr_bad_start) |
| && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_DESCR_BAD_START_RECHECK_MAYBE_", |
| "TRUE")) |
| && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_DESCR_BAD_START_RECHECK_START_", |
| "2016")))) { |
| descr0 <- trimws(as.vector(meta0["Description"])) |
| descr0 <- gsub("[\n\t]", " ", descr0) |
| if(grepl(paste0("^['\"]?", package), ignore.case = TRUE, descr0) |
| || grepl("^(The|This|A|In this|In the) package", descr0)){ |
| out$descr_bad_start <- NULL |
| } |
| } |
| |
| # possible GNU make usage and only report if this is new |
| if(NROW(out$GNUmake) |
| && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_GNU_MAKE_RECHECK_MAYBE_", |
| "TRUE")) |
| && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_GNU_MAKE_RECHECK_START_", |
| "2015")))) { |
| SysReq0 <- meta0["SystemRequirements"] |
| if(!is.na(SysReq0) && grepl("GNU [Mm]ake", SysReq0)) { |
| out$GNUmake <- NULL |
| } |
| } |
| } |
| |
| out |
| } |
| |
| format.check_package_CRAN_incoming <- |
| function(x, ...) |
| { |
| fmt <- function(x) { |
| if(length(x)) paste(x, collapse = "\n") else character() |
| } |
| |
| c(character(), |
| if(length(x$Maintainer)) |
| sprintf("Maintainer: %s", |
| sQuote(trimws(gsub("\n", " ", |
| paste(x$Maintainer, |
| collapse = " "))))) |
| else |
| "No maintainer field in DESCRIPTION file", |
| fmt(c(if(x$Maintainer_invalid_or_multi_person) |
| "The maintainer field is invalid or specifies more than one person", |
| if(x$empty_Maintainer_name) |
| 'The maintainer field lacks a name', |
| if(x$Maintainer_needs_quotes) |
| 'The display-name part of the maintainer field should be enclosed in ""') |
| ), |
| if(length(x$new_submission)) |
| "New submission", |
| if(length(y <- x$bad_package)) |
| sprintf("Conflicting package names (submitted: %s, existing: %s)", |
| y[[1L]], y[[2L]]), |
| if(length(y <- x$repositories)) |
| sprintf("Package duplicated from %s", y), |
| if(length(y <- x$CRAN_archive)) |
| "Package was archived on CRAN", |
| fmt(c(if(length(y <- x$bad_version)) |
| sprintf("Insufficient package version (submitted: %s, existing: %s)", |
| y[[1L]], y[[2L]]), |
| if(length(y <- x$version_with_leading_zeroes)) |
| sprintf("Version contains leading zeroes (%s)", y), |
| if(length(y <- x$version_with_large_components)) |
| sprintf("Version contains large components (%s)", y), |
| if(length(y <- x$version_with_jump_in_minor)) |
| sprintf("Version jumps in minor (submitted: %s, existing: %s)", |
| y[[1L]], y[[2L]]))), |
| fmt(c(if(length(y <- x$recency)) |
| sprintf("Days since last update: %d", y), |
| if(length(y <- x$frequency)) |
| sprintf("Number of updates in past 6 months: %d", y))), |
| if(length(y <- x$new_maintainer)) |
| paste(c("New maintainer:", |
| strwrap(y[[1L]], indent = 2L, exdent = 4L), |
| "Old maintainer(s):", |
| strwrap(y[[2L]], indent = 2L, exdent = 4L)), |
| collapse = "\n"), |
| fmt(c(if(length(y <- x$bad_license)) |
| sprintf("Non-FOSS package license (%s)", y), |
| if(length(y <- x$new_license)) |
| paste(c("Change to non-FOSS package license.", |
| "New license:", |
| strwrap(y[[1L]], indent = 2L, exdent = 4L), |
| "Old license:", |
| strwrap(y[[2L]], indent = 2L, exdent = 4L)), |
| collapse = "\n"), |
| if(length(y <- x$extensions)) { |
| paste(c("License components with restrictions and base license permitting such:", |
| paste0(" ", y), |
| unlist(lapply(x$pointers, |
| function(e) { |
| c(sprintf("File '%s':", e[1L]), |
| paste0(" ", e[-1L])) |
| }))), |
| collapse = "\n") |
| })), |
| if(NROW(y <- x$spelling)) { |
| s <- split(sprintf("%d:%d", y$Line, y$Column), y$Original) |
| paste(c("Possibly mis-spelled words in DESCRIPTION:", |
| sprintf(" %s (%s)", |
| names(s), |
| lapply(s, paste, collapse = ", "))), |
| collapse = "\n") |
| }, |
| if(isTRUE(x$foss_with_BuildVignettes)) { |
| "FOSS licence with BuildVignettes: false" |
| }, |
| if(length(y <- x$fields)) { |
| paste(c("Unknown, possibly mis-spelled, fields in DESCRIPTION:", |
| sprintf(" %s", paste(sQuote(y), collapse = " "))), |
| collapse = "\n") |
| }, |
| fmt(c(if(length(y <- x$overrides)) { |
| paste(c("CRAN repository db overrides:", y), |
| collapse = "\n") |
| }, |
| if(length(y <- x$conflicts)) { |
| paste(sprintf("CRAN repository db conflicts: %s", |
| sQuote(y)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$conflict_in_license_is_FOSS)) { |
| sprintf("Package license conflicts with %s override", |
| sQuote(paste("License_is_FOSS:", y))) |
| }, |
| if(length(y <- x$conflict_in_license_restricts_use)) { |
| sprintf("Package license conflicts with %s override", |
| sQuote(paste("License_restricts_use:", y))) |
| })), |
| fmt(c(if(length(y <- x$depends_with_restricts_use_TRUE)) { |
| paste(c("Package has a FOSS license but eventually depends on the following", |
| if(length(y) > 1L) |
| "packages which restrict use:" |
| else |
| "package which restricts use:", |
| strwrap(paste(y, collapse = ", "), |
| indent = 2L, exdent = 4L)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$depends_with_restricts_use_NA)) { |
| paste(c("Package has a FOSS license but eventually depends on the following", |
| if(length(y) > 1L) |
| "packages which may restrict use:" |
| else |
| "package which may restrict use:", |
| strwrap(paste(y, collapse = ", "), |
| indent = 2L, exdent = 4L)), |
| collapse = "\n") |
| })), |
| fmt(c(if(length(y <- x$strong_dependencies_not_in_mainstream_repositories)) { |
| paste(c("Strong dependencies not in mainstream repositories:", |
| strwrap(paste(y, collapse = ", "), |
| indent = 2L, exdent = 4L)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$suggests_or_enhances_not_in_mainstream_repositories)) { |
| paste(c("Suggests or Enhances not in mainstream repositories:", |
| strwrap(paste(y, collapse = ", "), |
| indent = 2L, exdent = 4L)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$additional_repositories_analysis_failed_with)) { |
| paste(c("Using Additional_repositories specification failed with:", |
| paste0(" ", y)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$additional_repositories_analysis_results)) { |
| paste(c("Availability using Additional_repositories specification:", |
| sprintf(" %s %s %s", |
| format(y[, 1L], justify = "left"), |
| format(y[, 2L], justify = "right"), |
| format(y[, 3L], justify = "left"))), |
| collapse = "\n") |
| }, |
| if(length(y <- x$additional_repositories_with_no_packages)) { |
| paste(c("Additional repositories with no packages:", |
| paste0(" ", y)), |
| collapse = "\n") |
| })), |
| if(length(y <- x$uses)) { |
| paste(if(length(y) > 1L) |
| "Uses the superseded packages:" else |
| "Uses the superseded package:", |
| paste(sQuote(y), collapse = ", ")) |
| }, |
| if(length(y <- x$BUGS)) { |
| paste(if(length(y) > 1L) |
| "Uses the non-portable packages:" else |
| "Uses the non-portable package:", |
| paste(sQuote(y), collapse = ", ")) |
| }, |
| if(length(y <- x$authors_at_R_calls)) { |
| "Authors@R field should be a call to person(), or combine such calls." |
| }, |
| if(length(y <- x$authors_at_R_message)) { |
| paste(c("Authors@R field gives persons with deprecated elements:", |
| paste0(" ", y)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$author_starts_with_Author)) { |
| "Author field starts with 'Author:'." |
| }, |
| if(length(y <- x$author_should_be_authors_at_R)) { |
| paste(c("Author field should be Authors@R. Current value is:", |
| paste0(" ", gsub("\n", "\n ", y))), |
| collapse = "\n") |
| }, |
| if(length(y <- x$vignette_sources_only_in_inst_doc)) { |
| if(isFALSE(x$have_vignettes_dir)) |
| paste(c("Vignette sources in 'inst/doc' with no 'vignettes' directory:", |
| strwrap(paste(sQuote(y), collapse = ", "), |
| indent = 2L, exdent = 2L), |
| "A 'vignettes' directory is required as from R 3.1.0"), |
| collapse = "\n") |
| else |
| paste(c("Vignette sources in 'inst/doc' missing from the 'vignettes' directory:", |
| strwrap(paste(sQuote(y), collapse = ", "), |
| indent = 2L, exdent = 2L)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$missing_vignette_index)) { |
| "Package has a VignetteBuilder field but no prebuilt vignette index." |
| }, |
| fmt(c(if(length(y <- x$missing_manual_rdb)) { |
| "Package has help file(s) containing build-stage \\Sexpr{} expressions but no 'build/partial.rdb' file." |
| }, |
| if(length(y <- x$missing_manual_pdf)) { |
| "Package has help file(s) containing install/render-stage \\Sexpr{} expressions but no prebuilt PDF manual." |
| })), |
| fmt(c(if(length(y <- x$dotjava)) { |
| "Package installs .java files." |
| }, |
| if(length(y <- x$javafiles)) { |
| "Package has FOSS license, installs .class/.jar but has no 'java' directory." |
| })), |
| fmt(c(if(length(y <- x$citation_calls)) { |
| paste(c("Package CITATION file contains call(s) to:", |
| strwrap(paste(y, collapse = ", "), |
| indent = 2L, exdent = 4L)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$citation_error_reading_if_installed)) { |
| paste(c("Reading CITATION file fails with", |
| paste0(" ", y)), |
| collapse = "\n") |
| }, |
| if(length(y <- x$citation_error_reading_if_not_installed)) { |
| paste(c("Reading CITATION file fails with", |
| paste0(" ", y), |
| "when package is not installed."), |
| collapse = "\n") |
| }, |
| if(length(y <- x$citation_problem_when_formatting)) { |
| paste(c("Problems when formatting CITATION entries:", |
| paste0(" ", y)), |
| collapse = "\n") |
| })), |
| fmt(c(if(length(y <- x$bad_urls)) { |
| if(inherits(y, "error")) |
| paste(c("Checking URLs failed with message:", |
| conditionMessage(y)), |
| collapse = "\n") |
| else |
| paste(c(if(length(y) > 1L) |
| "Found the following (possibly) invalid URLs:" |
| else |
| "Found the following (possibly) invalid URL:", |
| paste0(" ", gsub("\n", "\n ", format(y)))), |
| collapse = "\n") |
| }, |
| if(length(y) && any(nzchar(z <- y$CRAN))) { |
| ul <- tolower(z) |
| indp <- (grepl("^https?://cran.r-project.org/web/packages", |
| ul) & |
| !grepl("^https?://cran.r-project.org/web/packages/[.[:alnum:]]+(html|pdf|rds)$", |
| ul)) |
| indv <- grepl("https?://cran.r-project.org/web/views/[[:alnum:]]+[.]html$", |
| ul) |
| paste(c(if(any(indp)) { |
| c(" The canonical URL of the CRAN page for a package is ", |
| " https://CRAN.R-project.org/package=pkgname") |
| }, |
| if(any(indv)) { |
| c(" The canonical URL of the CRAN page for a task view is ", |
| " https://CRAN.R-project.org/view=viewname") |
| }, |
| if(any(nzchar(z) & !indp & !indv)) { |
| " Canonical CRAN.R-project.org URLs use https." |
| }), |
| collapse = "\n") |
| }, |
| if(length(y) && any(nzchar(y$Spaces))) { |
| " Spaces in an http[s] URL should probably be replaced by %20" |
| }, |
| if(length(y) && any(ind <- nzchar(z <- y$R))) { |
| ul <- tolower(z[ind]) |
| elts <- unique(sub("^http://([^.]+)[.].*", "\\1", ul)) |
| paste(sprintf(" Canonical %s.R-project.org URLs use https.", |
| elts), |
| collapse = "\n") |
| }, |
| if(length(y <- x$no_url_checks) && y) { |
| "Checking URLs requires 'libcurl' support in the R build" |
| })), |
| fmt(if(length(y <- x$bad_dois)) { |
| if(inherits(y, "error")) |
| paste(c("Checking DOIs failed with message:", |
| conditionMessage(y)), |
| collapse = "\n") |
| else |
| paste(c(if(length(y) > 1L) |
| "Found the following (possibly) invalid DOIs:" |
| else |
| "Found the following (possibly) invalid DOI:", |
| paste0(" ", gsub("\n", "\n ", format(y)))), |
| collapse = "\n") |
| }), |
| if(length(y <- x$R_files_non_ASCII)) { |
| paste(c("No package encoding and non-ASCII characters in the following R files:", |
| paste0(" ", names(y), "\n ", |
| vapply(y, paste, "", collapse = "\n "), |
| collapse = "\n")), |
| collapse = "\n") |
| }, |
| fmt(c(if(length(x$title_is_name)) { |
| "The Title field is just the package name: provide a real title." |
| }, |
| if(length(x$title_includes_name)) { |
| "The Title field starts with the package name." |
| }, |
| if(length(y <- x$title_case)) { |
| paste(c("The Title field should be in title case. Current version is:", |
| sQuote(y[1L]), "In title case that is:", sQuote(y[2L])), |
| collapse = "\n") |
| })), |
| fmt(c(if(length(x$descr_bad_initial)) { |
| "The Description field should start with a capital letter." |
| }, |
| if(length(x$descr_bad_start)) { |
| "The Description field should not start with the package name,\n 'This package' or similar." |
| }, |
| if(length(y <- x$descr_bad_URLs)) { |
| paste(c("The Description field contains", |
| paste0(" ", y), |
| "Please enclose URLs in angle brackets (<...>)."), |
| collapse = "\n") |
| }, |
| if(length(y <- x$descr_bad_DOIs)) { |
| paste(c("The Description field contains", |
| paste0(" ", y), |
| "Please write DOIs as <doi:10.prefix/suffix>."), |
| collapse = "\n") |
| }, |
| if(length(y <- x$descr_bad_arXiv_ids)) { |
| paste(c("The Description field contains", |
| paste0(" ", y), |
| "Please write arXiv ids as <arXiv:YYMM.NNNNN>."), |
| collapse = "\n") |
| } |
| )), |
| fmt(c(if(length(x$GNUmake)) { |
| "GNU make is a SystemRequirements." |
| })), |
| fmt(c(if(length(x$bad_date)) { |
| "The Date field is not in ISO 8601 yyyy-mm-dd format." |
| }, |
| if(length(x$old_date)) { |
| "The Date field is over a month old." |
| })), |
| if(length(y <- x$build_time_stamp_msg)) y, |
| if(length(y <- x$size_of_tarball)) |
| paste("Size of tarball:", y, "bytes") |
| ) |
| } |
| |
| print.check_package_CRAN_incoming <- |
| function(x, ...) |
| { |
| writeLines(paste(format(x, ...), collapse = "\n\n")) |
| invisible(x) |
| } |
| |
| ### * .check_Rd_metadata |
| |
| .check_Rd_metadata <- |
| function(package, dir, lib.loc = NULL) |
| { |
| ## Perform package-level Rd metadata checks: |
| ## names and aliases must be unique within a package. |
| |
| ## Note that we cannot use Rd_aliases(), as this does |
| ## if(length(aliases)) |
| ## sort(unique(unlist(aliases, use.names = FALSE))) |
| |
| out <- structure(list(), class = "check_Rd_metadata") |
| |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| rds <- file.path(dir, "Meta", "Rd.rds") |
| if(file_test("-f", rds)) { |
| meta <- readRDS(rds) |
| files <- meta$File |
| names <- meta$Name |
| aliases <- meta$Aliases |
| } else { |
| return(out) |
| } |
| } else { |
| if(dir.exists(file.path(dir, "man"))) { |
| db <- Rd_db(dir = dir) |
| files <- basename(names(db)) |
| names <- sapply(db, .Rd_get_metadata, "name") |
| aliases <- lapply(db, .Rd_get_metadata, "alias") |
| } else { |
| return(out) |
| } |
| } |
| |
| ## <FIXME> |
| ## Remove eventually, as .Rd_get_metadata() and hence Rd_info() now |
| ## eliminate duplicated entries ... |
| aliases <- lapply(aliases, unique) |
| ## </FIXME> |
| |
| files_grouped_by_names <- split(files, names) |
| files_with_duplicated_names <- |
| files_grouped_by_names[lengths(files_grouped_by_names) > 1L] |
| if(length(files_with_duplicated_names)) |
| out$files_with_duplicated_names <- |
| files_with_duplicated_names |
| |
| files_grouped_by_aliases <- |
| split(rep.int(files, lengths(aliases)), |
| unlist(aliases, use.names = FALSE)) |
| files_with_duplicated_aliases <- |
| files_grouped_by_aliases[lengths(files_grouped_by_aliases) > 1L] |
| if(length(files_with_duplicated_aliases)) |
| out$files_with_duplicated_aliases <- |
| files_with_duplicated_aliases |
| |
| out |
| } |
| |
| format.check_Rd_metadata <- |
| function(x, ...) |
| { |
| c(character(), |
| if(length(bad <- x$files_with_duplicated_name)) { |
| unlist(lapply(names(bad), |
| function(nm) { |
| c(gettextf("Rd files with duplicated name '%s':", |
| nm), |
| .pretty_format(bad[[nm]])) |
| })) |
| }, |
| if(length(bad <- x$files_with_duplicated_aliases)) { |
| unlist(lapply(names(bad), |
| function(nm) { |
| c(gettextf("Rd files with duplicated alias '%s':", |
| nm), |
| .pretty_format(bad[[nm]])) |
| })) |
| }) |
| } |
| |
| ## * .check_Rd_contents |
| |
| .check_Rd_contents <- |
| function(package, dir, lib.loc = NULL) |
| { |
| out <- list() |
| class(out) <- "check_Rd_contents" |
| |
| ## Argument handling. |
| if(!missing(package)) { |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| ## Using package installed in @code{dir} ... |
| } |
| else { |
| if(missing(dir)) |
| stop("you must specify 'package' or 'dir'") |
| ## Using sources from directory @code{dir} ... |
| if(!dir.exists(dir)) |
| stop(gettextf("directory '%s' does not exist", dir), |
| domain = NA) |
| else |
| dir <- file_path_as_absolute(dir) |
| } |
| |
| db <- if(!missing(package)) |
| Rd_db(package, lib.loc = dirname(dir)) |
| else |
| Rd_db(dir = dir) |
| |
| names(db) <- .Rd_get_names_from_Rd_db(db) |
| |
| ## Exclude internal objects from further computations. |
| ind <- (vapply(lapply(db, .Rd_get_metadata, "keyword"), |
| function(x) match("internal", x, 0L), |
| 0L) > 0L) |
| if(any(ind)) # exclude them |
| db <- db[!ind] |
| |
| for(nm in names(db)) { |
| rd <- db[[nm]] |
| |
| ## Arguments with no description. |
| arg_table <- .Rd_get_argument_table(rd) |
| arguments_with_no_description <- |
| arg_table[grepl("^[[:blank:]]*$", arg_table[, 2L]), |
| 1L] |
| |
| ## Autogenerated Rd content which needs editing. |
| offending_autogenerated_content <- |
| .Rd_get_offending_autogenerated_content(rd) |
| |
| if(length(arguments_with_no_description) |
| || length(offending_autogenerated_content)) { |
| out[[nm]] <- |
| list(arguments_with_no_description = |
| arguments_with_no_description, |
| offending_autogenerated_content = |
| offending_autogenerated_content) |
| } |
| } |
| |
| out |
| } |
| |
| format.check_Rd_contents <- |
| function(x, ...) |
| { |
| .fmt <- function(nm) { |
| y <- x[[nm]] |
| c(if(length(arguments_with_no_description <- |
| y[["arguments_with_no_description"]])) { |
| c(gettextf("Argument items with no description in Rd object '%s':", |
| nm), |
| .pretty_format(arguments_with_no_description)) |
| }, |
| if(length(offending_autogenerated_content <- |
| y[["offending_autogenerated_content"]])) { |
| c(gettextf("Auto-generated content requiring editing in Rd object '%s':", |
| nm), |
| sprintf(" %s", offending_autogenerated_content[, 1L])) |
| }, |
| "") |
| } |
| |
| as.character(unlist(lapply(names(x), .fmt))) |
| } |
| |
| ### * .check_Rd_line_widths |
| |
| .check_Rd_line_widths <- |
| function(dir, limit = c(usage = 95, examples = 105), installed = FALSE) |
| { |
| db <- if(installed) |
| Rd_db(basename(dir), lib.loc = dirname(dir)) |
| else |
| Rd_db(dir = dir) |
| out <- find_wide_Rd_lines_in_Rd_db(db, limit) |
| class(out) <- "check_Rd_line_widths" |
| attr(out, "limit") <- limit |
| out |
| } |
| |
| format.check_Rd_line_widths <- |
| function(x, ...) |
| { |
| if(!length(x)) return(character()) |
| |
| .truncate <- function(s) { |
| ifelse(nchar(s) > 140L, |
| paste(substring(s, 1, 140L), |
| "... [TRUNCATED]"), |
| s) |
| } |
| |
| limit <- attr(x, "limit") |
| ## Rd2txt() by default adds a section indent of 5 also incorporated |
| ## in the limits used for checking. But users actually look at the |
| ## line widths in their source Rd file, so remove the indent when |
| ## formatting for reporting check results. |
| ## (This should reduce confusion as long as we only check the line |
| ## widths in verbatim type sections.) |
| limit <- limit - 5L |
| |
| sections <- names(limit) |
| |
| .fmt <- function(nm) { |
| y <- x[[nm]] |
| c(sprintf("Rd file '%s':", nm), |
| unlist(lapply(sections, |
| function(s) { |
| lines <- y[[s]] |
| if(!length(lines)) character() else { |
| c(sprintf(" \\%s lines wider than %d characters:", |
| s, limit[s]), |
| .truncate(lines)) |
| } |
| }), |
| use.names = FALSE), |
| "") |
| } |
| |
| as.character(unlist(lapply(names(x), .fmt))) |
| } |
| |
| find_wide_Rd_lines_in_Rd_db <- |
| function(x, limit = NULL) |
| { |
| y <- lapply(x, find_wide_Rd_lines_in_Rd_object, limit) |
| Filter(length, y) |
| } |
| |
| find_wide_Rd_lines_in_Rd_object <- |
| function(x, limit = NULL) |
| { |
| if(is.null(limit)) |
| limit <- list(usage = c(79, 95), examples = c(87, 105)) |
| sections <- names(limit) |
| if(is.null(sections)) |
| stop("no Rd sections specified") |
| y <- Map(function(s, l) { |
| out <- NULL |
| zz <- textConnection("out", "w", local = TRUE) |
| on.exit(close(zz)) |
| pos <- which(RdTags(x) == s) |
| ## measure length in chars, not in bytes after substitutions |
| Rd2txt(x[pos[1L]], out = zz, fragment = TRUE, outputEncoding = "UTF-8") |
| nc <- nchar(out) |
| if(length(l) > 1L) { |
| ind_warn <- (nc > max(l)) |
| ind_note <- (nc > min(l)) & !ind_warn |
| Filter(length, |
| list(warn = out[ind_warn], note = out[ind_note])) |
| } else { |
| out[nc > l] |
| } |
| }, |
| paste0("\\", sections), |
| limit) |
| names(y) <- sections |
| Filter(length, y) |
| } |
| |
| |
| ### * .find_charset |
| |
| .find_charset <- |
| function() |
| { |
| l10n <- l10n_info() |
| enc <- if(l10n[["UTF-8"]]) "UTF-8" else utils::localeToCharset() |
| cat("charset: ", enc, "\n", sep = "") |
| invisible() |
| } |
| |
| |
| ### * Utilities |
| |
| ### ** as.alist.call |
| |
| as.alist.call <- |
| function(x) |
| { |
| y <- as.list(x) |
| ind <- if(is.null(names(y))) |
| seq_along(y) |
| else |
| which(names(y) == "") |
| if(length(ind)) { |
| names(y)[ind] <- vapply(y[ind], paste, "", collapse = " ") |
| y[ind] <- rep.int(list(alist(irrelevant = )[[1L]]), length(ind)) |
| } |
| y |
| } |
| |
| ### ** as.alist.symbol |
| |
| as.alist.symbol <- |
| function(x) |
| { |
| as.alist.call(call(as.character(x))) |
| } |
| |
| ### ** .arg_names_from_call |
| |
| .arg_names_from_call <- |
| function(x) |
| { |
| y <- as.character(x) |
| if(!is.null(nx <- names(x))) { |
| ind <- which(nzchar(nx)) |
| y[ind] <- nx[ind] |
| } |
| y |
| } |
| |
| ### ** .dquote_method_markup |
| |
| ## See the notes below. |
| ## An alternative and possibly more efficient implementation could be |
| ## based using gregexpr(re, txt), massaging the matches and merging with |
| ## the non-matched parts. |
| |
| .dquote_method_markup <- |
| function(txt, re) |
| { |
| out <- "" |
| while((ipos <- regexpr(re, txt)) > -1L) { |
| epos <- ipos + attr(ipos, "match.length") - 1L |
| str <- substring(txt, ipos, epos) |
| str <- sub("\"", "\\\"", str, fixed = TRUE) |
| str <- sub("\\", "\\\\", str, fixed = TRUE) |
| out <- sprintf("%s%s\"%s\"", out, |
| substring(txt, 1L, ipos - 1L), str) |
| txt <- substring(txt, epos + 1L) |
| } |
| paste0(out, txt) |
| } |
| |
| ### ** .format_calls_in_file |
| |
| .format_calls_in_file <- |
| function(calls, f) |
| { |
| c(gettextf("File %s:", sQuote(f)), |
| paste0(" ", |
| unlist(lapply(calls, |
| function(e) |
| paste(deparse(e), collapse = "\n"))))) |
| } |
| |
| ### ** .functions_to_be_ignored_from_usage |
| |
| .functions_to_be_ignored_from_usage <- |
| function(package_name) |
| { |
| c("<-", "=", |
| if(package_name == "base") |
| c("(", "{", "function", "if", "for", "while", "repeat", |
| "Math", "Ops", "Summary", "Complex"), |
| if(package_name == "utils") "?", |
| if(package_name == "methods") "@") |
| } |
| |
| ### ** get_S4_generics_with_methods |
| |
| ## FIXME: make option of methods::getGenerics() |
| ## JMC agreed & proposed argument 'excludeEmpty = FALSE' |
| get_S4_generics_with_methods <- |
| function(env, verbose = getOption("verbose")) |
| { |
| env <- as.environment(env) |
| ## Filter(function(g) methods::isGeneric(g, where = env), |
| ## methods::getGenerics(env)) |
| r <- methods::getGenerics(env) |
| if(length(r) && { |
| hasM <- lapply(r, function(g) |
| tryCatch(methods::hasMethods(g, where = env), |
| error = identity)) |
| if(any(hasErr <- vapply(hasM, inherits, NA, what = "error"))) { |
| dq <- function(ch) paste0('"', ch ,'"') |
| rErr <- r[hasErr] |
| pkgs <- r@package[hasErr] |
| ## FIXME: This warning should not happen here when called |
| ## from R CMD check, but rather be part of a new "check" |
| ## there ! |
| warning(gettextf("Generics 'g' in 'env' %s where '%s' errors: %s\nMay need something like\n\n%s\nin NAMESPACE.", |
| format(env), |
| "hasMethods(g, env)", |
| paste(sQuote(rErr), collapse = ", "), |
| paste0(" importFrom(", |
| paste(dq(pkgs), dq(rErr), sep =", "), |
| ")\n") |
| ), |
| domain = NA) |
| hasM <- hasM[!hasErr] |
| } |
| !all(ok <- unlist(hasM)) |
| }) { |
| if(verbose) |
| message(sprintf(ngettext(sum(!ok), |
| "Generic without any methods in %s: %s", |
| "Generics without any methods in %s: %s"), |
| format(env), |
| paste(sQuote(r[!ok]), collapse = ", ")), |
| domain = NA) |
| r[ok] |
| } |
| else as.vector(r)# for back-compatibility and current ..../tests/reg-S4.R |
| } |
| |
| ### ** .get_S4_generics |
| |
| ## For several QC tasks, we need to compute on "all S4 methods in/from a |
| ## package". These days, this can straightforwardly be accomplished by |
| ## looking at all methods tables in the package environment or namespace. |
| ## Somewhat historically, we organize our computations by first using |
| ## using methods::getGenerics() to find all S4 generics the package has |
| ## methods for, and then iterating over these. To make this work |
| ## conveniently, we wrap around methods::getGenerics() to rewrite its |
| ## "ObjectsWithPackage" result into a (currently unclassed) list of |
| ## generic-name-with-package-name-attribute objects, and wrap around |
| ## methods::findMethods() to perform lookup based on this information |
| ## (rather than the genericFunction object itself), and also rewrite the |
| ## MethodsList result into a simple list. |
| |
| .get_S4_generics <- |
| function(env) |
| { |
| env <- as.environment(env) |
| g <- suppressMessages(methods::getGenerics(env)) |
| Map(function(f, p) { |
| attr(f, "package") <- p |
| f |
| }, |
| g@.Data, |
| g@package) |
| } |
| |
| ### ** .get_S4_methods_list |
| |
| .get_S4_methods_list <- |
| function(f, env) |
| { |
| ## Get S4 methods in environment env for f a structure with the name |
| ## of the S4 generic and its package in the corresponding attribute. |
| |
| ## For the QC computations, we really only want the S4 methods |
| ## defined in a package, so we try to exclude derived default |
| ## methods as well as methods inherited from other environments. |
| |
| env <- as.environment(env) |
| |
| ## <FIXME> |
| ## Use methods::findMethods() once this gets a package argument. |
| ## This will return a listOfMethods object: turn this into a simple |
| ## list of methods named by hash-collapsed signatures. |
| tab <- get(methods:::.TableMetaName(f, attr(f, "package")), envir = env) |
| mlist <- as.list(tab, all.names = TRUE, sorted = TRUE) |
| ## </FIXME> |
| |
| ## First, derived default methods (signature w/ "ANY"). |
| if(any(ind <- vapply(mlist, methods::is, NA, "derivedDefaultMethod"))) |
| mlist <- mlist[!ind] |
| |
| if(length(mlist)) { |
| ## Determining the methods defined in a package from the package |
| ## env or the associated namespace seems rather tricky. What we |
| ## seem to observe is the following. |
| ## * If there is a namespace N, methods defined in the package |
| ## have N as their environment, for both the package env and |
| ## the associated namespace. |
| ## * If there is no namespace, methods defined in the package |
| ## have an environment E which is empty and has globalenv() as |
| ## its parent. (If the package defines generics, these seem |
| ## to have E as their parent env.) |
| ## However, in the latter case, there seems no way to infer E |
| ## from the package env. In the old days predating methods |
| ## tables, we compared methods in the package env with those in |
| ## its parent env, and excluded the ones already found there. |
| ## This no longer works, so we exclude "at least" all methods |
| ## with a namespace environment (as these cannot come from a |
| ## package with no namespace). |
| |
| namespace <- if(isNamespace(env)) env else .get_namespace_from_package_env(env) |
| mlist <- if(!is.null(namespace)) |
| Filter(function(m) identical(environment(m), namespace), mlist) |
| else |
| Filter(function(m) environmentName(environment(m)) == "", mlist) |
| } |
| |
| mlist |
| } |
| |
| .get_ref_classes <- |
| function(env) |
| { |
| env <- as.environment(env) |
| cl <- methods::getClasses(env) |
| cl <- cl[vapply(cl, |
| function(Class) |
| methods::is(methods::getClass(Class, where = env), |
| "refClassRepresentation"), |
| NA)] |
| if(length(cl)) { |
| res <- lapply(cl, function(Class) { |
| def <- methods::getClass(Class, where = env) |
| ff <- def@fieldPrototypes |
| accs <- vapply(ff, |
| function(what) |
| methods::is(what, "activeBindingFunction") && |
| !methods::is(what, "defaultBindingFunction"), |
| NA) |
| c(as.list(def@refMethods), as.list(ff)[accs]) |
| }) |
| names(res) <- cl |
| res |
| } else list() |
| } |
| |
| .get_namespace_from_package_env <- |
| function(env) |
| { |
| package <- |
| sub(".*:([^_]*).*", "\\1", attr(env, "name", exact = TRUE)) |
| if(length(package) && nzchar(package)) .getNamespace(as.name(package)) |
| } |
| |
| |
| ### ** .is_call_from_replacement_function_usage |
| |
| .is_call_from_replacement_function_usage <- |
| function(x) |
| { |
| ((length(x) == 3L) |
| && identical(x[[1L]], quote(`<-`)) |
| && (length( x[[2L]]) > 1L) |
| && is.symbol(x[[3L]])) |
| } |
| |
| ### ** .make_siglist |
| |
| .make_siglist <- |
| function(x) |
| { |
| ## Argument 'x' should be a named list of methods as obtained by |
| ## methods::findMethods() or .get_S4_methods_list(). |
| gsub("#", ",", names(x), fixed = TRUE) |
| } |
| |
| ### ** .make_signatures |
| |
| .make_signatures <- |
| function(cls) |
| { |
| ## Note that (thanks JMC), when comparing signatures, the signature |
| ## has to be stripped of trailing "ANY" elements (which are always |
| ## implicit) or padded to a fixed length. |
| sub("(#ANY)*$", "", unlist(lapply(cls, paste, collapse = "#"))) |
| } |
| |
| ### ** .massage_file_parse_error_message |
| |
| .massage_file_parse_error_message <- |
| function(x) |
| sub("^[^:]+:[[:space:]]*", "", x) |
| |
| ### ** .package_env |
| |
| .package_env <- |
| function(package_name) |
| { |
| as.environment(paste0("package:", package_name)) |
| } |
| |
| ### ** .parse_text_as_much_as_possible |
| |
| .parse_text_as_much_as_possible <- |
| function(txt) |
| { |
| exprs <- tryCatch(parse(text = txt), error = identity) |
| if(!inherits(exprs, "error")) return(exprs) |
| exprs <- expression() |
| lines <- unlist(strsplit(txt, "\n")) |
| bad_lines <- character() |
| while((n <- length(lines))) { |
| i <- 1L; txt <- lines[1L] |
| while(inherits(yy <- tryCatch(parse(text = txt), |
| error = identity), |
| "error") |
| && (i < n)) { |
| i <- i + 1L; txt <- paste(txt, lines[i], collapse = "\n") |
| } |
| if(inherits(yy, "error")) { |
| bad_lines <- c(bad_lines, lines[1L]) |
| lines <- lines[-1L] |
| } |
| else { |
| exprs <- c(exprs, yy) |
| lines <- lines[-seq_len(i)] |
| } |
| } |
| attr(exprs, "bad_lines") <- bad_lines |
| exprs |
| } |
| |
| ### ** .parse_usage_as_much_as_possible |
| |
| .parse_usage_as_much_as_possible <- |
| function(x) |
| { |
| if(!length(x)) return(expression()) |
| ## Drop specials and comments. |
| ## <FIXME> |
| ## Remove calling .Rd_drop_comments() eventually. |
| x <- .Rd_drop_comments(x) |
| ## </FIXME> |
| txt <- .Rd_deparse(.Rd_drop_nodes_with_tags(x, "\\special"), |
| tag = FALSE) |
| txt <- gsub("\\\\l?dots", "...", txt) |
| txt <- .dquote_method_markup(txt, .S3_method_markup_regexp) |
| txt <- .dquote_method_markup(txt, .S4_method_markup_regexp) |
| ## Transform <<see below>> style markup so that we can catch and |
| ## throw it, rather than "basically ignore" it by putting it in the |
| ## bad_lines attribute. |
| txt <- gsub("(<<?see below>>?)", "`\\1`", txt) |
| ## \usage is only 'verbatim-like' |
| ## ## <FIXME> |
| ## ## 'LanguageClasses.Rd' in package methods has '"\{"' in its usage. |
| ## ## But why should it use the backslash escape? |
| ## txt <- gsub("\\{", "{", txt, fixed = TRUE) |
| ## txt <- gsub("\\}", "}", txt, fixed = TRUE) |
| ## ## </FIXME> |
| ## now any valid escape by \ is |
| ## \a \b \f \n \r \t \u \U \v \x \' \" \\ or \octal |
| txt <- gsub("(^|[^\\])\\\\($|[^abfnrtuUvx0-9'\"\\])", |
| "\\1<unescaped bksl>\\2", txt) |
| ## and since this may overlap, try again |
| txt <- gsub("(^|[^\\])\\\\($|[^abfnrtuUvx0-9'\"\\])", |
| "\\1<unescaped bksl>\\2", txt) |
| .parse_text_as_much_as_possible(txt) |
| } |
| |
| ### ** .pretty_format |
| |
| .strwrap22 <- function(x, collapse = " ") |
| strwrap(paste(x, collapse=collapse), indent = 2L, exdent = 2L) |
| |
| .pretty_format <- |
| function(x, collapse = " ", q = getOption("useFancyQuotes")) |
| .strwrap22(sQuote(x, q=q), collapse=collapse) |
| |
| .pretty_format2 <- |
| function(msg, x, collapse = ", ", useFancyQuotes = FALSE) |
| { |
| xx <- strwrap(paste(sQuote(x, q=q), collapse=collapse), exdent = 2L) |
| if (length(xx) > 1L || nchar(msg) + nchar(xx) + 1L > 75L) |
| ## trash 'xx', instead wrap w/ 'indent' : |
| c(msg, .pretty_format(x, collapse=collapse, q=q)) |
| else paste(msg, xx) |
| } |
| |
| ### ** .pretty_print |
| |
| .pretty_print <- |
| function(x, collapse = " ") |
| writeLines(.strwrap22(x, collapse=collapse)) |
| |
| |
| ### ** .strip_backticks |
| |
| .strip_backticks <- |
| function(x) |
| gsub("`", "", x) |
| |
| ### ** .transform_S3_method_markup |
| |
| .transform_S3_method_markup <- |
| function(x) |
| { |
| ## Note how we deal with S3 replacement methods found. |
| ## These come out named "\method{GENERIC}{CLASS}<-" which we |
| ## need to turn into 'GENERIC<-.CLASS'. |
| re <- sprintf("%s(<-)?", .S3_method_markup_regexp) |
| ## Note that this is really only called on "function" names obtained |
| ## by parsing the \usage texts, so that the method regexps possibly |
| ## augmented by '<-' fully match if they match. |
| ## We should be able to safely strip all backticks; alternatively, |
| ## we could do something like |
| ## cl <- .strip_backticks(sub(re, "\\4", x)) |
| ## sub(re, sprintf("\\3\\5.%s", cl), x) |
| .strip_backticks(sub(re, "\\3\\5.\\4", x)) |
| } |
| |
| ### ** .transform_S4_method_markup |
| |
| .transform_S4_method_markup <- |
| function(x) |
| { |
| re <- sprintf("%s(<-)?", .S4_method_markup_regexp) |
| ## We should be able to safely strip all backticks; alternatively, |
| ## we could do something like |
| ## sl <- .strip_backticks(sub(re, "\\3", x)) |
| ## sub(re, sprintf("\\\\S4method{\\2\\7}{%s}", sl), x) |
| .strip_backticks(sub(re, "\\\\S4method{\\2\\7}{\\3}", x)) |
| } |
| |
| ### ** .S3_method_markup_regexp |
| |
| ## For matching \(S3)?method{GENERIC}{CLASS}. |
| ## GENERIC can be |
| ## * a syntactically valid name |
| ## * one of $ [ [[ |
| ## * one of the binary operators |
| ## + - * / ^ < <= > >= != == | & %something% |
| ## * unary ! |
| ## (as supported by Rdconv). |
| ## CLASS can be a syntactic name (we could be more precise about the |
| ## fact that these must start with a letter or '.'), or anything quoted |
| ## by backticks (not containing backticks itself for now). Arguably, |
| ## non-syntactic class names should best be avoided, but R has always |
| ## had them at least for |
| ## R> class(bquote({.})) |
| ## [1] "{" |
| ## R> class(bquote((.))) |
| ## [1] "(" |
| |
| ## <NOTE> |
| ## Handling S3/S4 method markup is somewhat tricky. |
| ## When using R to parse the usage entries, we turn the |
| ## \METHOD{GENERIC}{CLASS_OR_SIGLIST}(args) |
| ## markup into (something which parses to) a function call by suitably |
| ## quoting the \METHOD{GENERIC}{CLASS_OR_SIGLIST} part. In case of a |
| ## replacement method |
| ## \METHOD{GENERIC}{CLASS_OR_SIGLIST}(args) <- value |
| ## parsing results in a |
| ## \METHOD{GENERIC}{CLASS_OR_SIGLIST}<- |
| ## pseudo name, which need to be transformed to |
| ## \METHOD{GENERIC<-}{CLASS_OR_SIGLIST} |
| ## We currently use double quoting for the parse step. As we also allow |
| ## for non-syntactic class names quoted by backticks, this means that |
| ## double quotes and backslashes need to be escaped. Alternatively, we |
| ## could strip backticks right away and quote by backticks, but then the |
| ## replacement method transformation would need different regexps. |
| ## </NOTE> |
| |
| .S3_method_markup_regexp <- |
| sprintf("(\\\\(S3)?method\\{(%s)\\}\\{(%s)\\})", |
| paste(c("[._[:alnum:]]*", |
| ## Subscripting |
| "\\$", "\\[\\[?", |
| ## Binary operators and unary '!'. |
| "\\+", "\\-", "\\*", "\\/", "\\^", |
| "<=?", ">=?", "!=?", "==", "\\&", "\\|", |
| "\\%[[:alnum:][:punct:]]*\\%"), |
| collapse = "|"), |
| "[._[:alnum:]]+|`[^`]+`") |
| |
| ### ** .S4_method_markup_regexp |
| |
| ## For matching \S4method{GENERIC}{SIGLIST}. |
| ## SIGLIST can be a comma separated list of CLASS specs as above. |
| |
| .S4_method_markup_regexp <- |
| sprintf("(\\\\S4method\\{(%s)\\}\\{(%s)\\})", |
| paste(c("[._[:alnum:]]*", |
| ## Subscripting |
| "\\$", "\\[\\[?", |
| ## Binary operators and unary '!'. |
| "\\+", "\\-", "\\*", "\\/", "\\^", |
| "<=?", ">=?", "!=?", "==", "\\&", "\\|", |
| "\\%[[:alnum:][:punct:]]*\\%"), |
| collapse = "|"), |
| "(([._[:alnum:]]+|`[^`]+`),)*([._[:alnum:]]+|`[^`]+`)") |
| |
| ### ** .valid_maintainer_field_regexp |
| |
| .make_RFC_2822_email_address_regexp <- |
| function() |
| { |
| ## Local part consists of ASCII letters and digits, the characters |
| ## ! # $ % * / ? | ^ { } ` ~ & ' + = _ - |
| ## and . provided it is not leading or trailing or repeated, or must |
| ## be a quoted string. |
| ## Domain part consists of dot-separated elements consisting of |
| ## ASCII letters, digits and hyphen. |
| ## We could also check that the local and domain parts are no longer |
| ## than 64 and 255 characters, respectively. |
| ## See https://en.wikipedia.org/wiki/Email_address. |
| ASCII_letters_and_digits <- |
| "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" |
| l <- sprintf("[%s%s]", ASCII_letters_and_digits, "!#$%*/?|^{}`~&'+=_-") |
| d <- sprintf("[%s%s]", ASCII_letters_and_digits, "-") |
| ## Be careful to arrange the hyphens to come last in the range spec. |
| sprintf("(\\\".+\\\"|(%s+\\.)*%s+)@(%s+\\.)*%s+", l, l, d, d) |
| } |
| |
| .valid_maintainer_field_regexp <- |
| sprintf("^[[:space:]]*(.*<%s>|ORPHANED)[[:space:]]*$", |
| .make_RFC_2822_email_address_regexp()) |
| |
| ### ** .Rd_get_offending_autogenerated_content |
| |
| .Rd_get_offending_autogenerated_content <- |
| function(x) |
| { |
| out <- NULL |
| |
| ## /data/rsync/PKGS/geoR/man/globalvar.Rd |
| s <- .Rd_get_section(x, "title") |
| if(length(s)) { |
| s <- .Rd_deparse(s, tag = FALSE) |
| if(trimws(s) == "~~function to do ... ~~") |
| out <- rbind(out, c("\\title", s)) |
| } |
| s <- .Rd_get_section(x, "description") |
| if(length(s)) { |
| s <- .Rd_deparse(s, tag = FALSE) |
| if(trimws(s) == |
| "~~ A concise (1-5 lines) description of what the function does. ~~") |
| out <- rbind(out, c("\\description", s)) |
| } |
| s <- .Rd_get_section(x, "details") |
| if(length(s)) { |
| s <- .Rd_deparse(s, tag = FALSE) |
| if(trimws(s) == |
| "~~ If necessary, more details than the description above ~~") |
| out <- rbind(out, c("\\details", s)) |
| } |
| |
| ## /data/rsync/PKGS/mimR/man/plot.Rd:\author{ ~~who you are~~ } |
| s <- .Rd_get_section(x, "author") |
| if(length(s)) { |
| s <- .Rd_deparse(s, tag = FALSE) |
| if(trimws(s) == "~~who you are~~") |
| out <- rbind(out, c("\\author", s)) |
| } |
| ## /data/rsync/PKGS/mimR/man/mim-class.Rd:\note{ ~~further notes~~ } |
| s <- .Rd_get_section(x, "note") |
| if(length(s)) { |
| s <- .Rd_deparse(s, tag = FALSE) |
| if(trimws(s) == "~~further notes~~") |
| out <- rbind(out, c("\\note", s)) |
| } |
| |
| tab <- .Rd_get_argument_table(x) |
| if(length(tab)) { |
| ## /data/rsync/PKGS/Rmpfr/man/mpfrArray.Rd: |
| ## \item{precBits}{ ~~Describe \code{precBits} here~~ } |
| descriptions <- trimws(tab[, 2L]) |
| ind <- (descriptions == |
| sprintf("~~Describe \\code{%s} here~~", tab[, 1L])) |
| if(any(ind)) |
| out <- rbind(out, |
| cbind(sprintf("\\arguments, description of item '%s'", |
| tab[ind, 1L]), |
| tab[ind, 2L])) |
| } |
| |
| ## <NOTE> |
| ## Obviously, auto-generation does too much here, so maybe do not |
| ## include these in production check code ... |
| tab <- .Rd_get_methods_description_table(x) |
| if(length(tab)) { |
| descriptions <- trimws(tab[, 2L]) |
| ## /data/rsync/PKGS/coin/man/initialize-methods.Rd |
| ind <- descriptions == "~~describe this method here" |
| if(any(ind)) |
| out <- rbind(out, |
| cbind(sprintf("section 'Methods', description of item '%s'", |
| tab[ind, 1L]), |
| tab[ind, 2L])) |
| } |
| ## </NOTE> |
| |
| if(config_val_to_logical(Sys.getenv("_R_CHECK_RD_CONTENTS_KEYWORDS_", |
| "FALSE"))) { |
| k <- .Rd_get_metadata(x, "keyword") |
| k <- k[!is.na(match(k, .Rd_keywords_auto))] |
| if(length(k)) { |
| ## Not quite perfect as .Rd_get_metadata() already calls |
| ## trimws() ... |
| out <- rbind(out, |
| cbind(sprintf("\\keyword{%s}", k), k)) |
| } |
| } |
| |
| out |
| } |
| |
| |
| ### ** .check_pragmas |
| |
| .check_pragmas <- |
| function(dir) |
| { |
| ## Check a source package for disallowed pragmas in src and inst/include |
| ## Try (not very hard) to avoid ones which are commented out (RcppParallel) |
| ## One could argue for recording all uses of #pragma ... diagnostic |
| ## There are also |
| ## #pragma warning (disable:4996) |
| ## #pragma warning(push, 0) |
| ## which seem intended for MSVC++ and hence not relevant here. |
| found <- warn <- port <- character() |
| od <- setwd(dir); on.exit(setwd(od)) |
| ff <- dir(c('src', 'inst/include'), |
| pattern = "[.](c|cc|cpp|h|hh|hpp)$", |
| full.names = TRUE, recursive = TRUE) |
| pat <- "^\\s*#pragma (GCC|clang) diagnostic ignored" |
| ## -Wmissing-field-initializers looks important but is not part of -Wall |
| pat2 <- "^\\s*#pragma (GCC|clang) diagnostic ignored[^-]*[-]W(uninitialized|float-equal|array-bound|format)" |
| ## gcc8 -W warnings not accepted by clang 7 |
| ## found by listing with gcc -Q --help=warning and testing with clang. |
| nonport <- |
| c("abi-tag", "aggressive-loop-optimizations", "aliasing", |
| "align-commons", "aligned-new", "alloc-size-larger-than", |
| "alloc-zero", "alloca", "alloca-larger-than", "ampersand", |
| "argument-mismatch", "array-temporaries", |
| "assign-intercept", "attribute-alias", "bool-compare", |
| "bool-operation", "builtin-declaration-mismatch", |
| "c-binding-type", "c90-c99-compat", "c99-c11-compat", |
| "cast-function-type", "catch-value", |
| "character-truncation", "chkp", "class-memaccess", |
| "clobbered", "compare-reals", "conditionally-supported", |
| "conversion-extra", "coverage-mismatch", "designated-init", |
| "discarded-array-qualifiers", "discarded-qualifiers", |
| "do-subscript", "duplicated-branches", "duplicated-cond", |
| "format-contains-nul", "format-overflow", |
| "format-signedness", "format-truncation", "frame-address", |
| "frame-larger-than", "free-nonheap-object", |
| "function-elimination", "hsa", "if-not-aligned", |
| "implicit-interface", "implicit-procedure", |
| "inherited-variadic-ctor", "int-in-bool-context", |
| "integer-division", "intrinsic-shadow", "intrinsics-std", |
| "invalid-memory-model", "jump-misses-init", "larger-than", |
| "line-truncation", "literal-suffix", "logical-op", |
| "lto-type-mismatch", "maybe-uninitialized", |
| "memset-elt-size", "misleading-indentation", |
| "missing-attributes", "missing-parameter-type", |
| "multiple-inheritance", "multistatement-macros", |
| "namespaces", "noexcept", "non-template-friend", |
| "nonnull-compare", "normalized", "old-style-declaration", |
| "openmp-simd", "override-init", |
| "override-init-side-effects", "packed-bitfield-compat", |
| "packed-not-aligned", "placement-new", "pmf-conversions", |
| "pointer-compare", "property-assign-default", "psabi", |
| "real-q-constant", "realloc-lhs", "realloc-lhs-all", |
| "restrict", "return-local-addr", "scalar-storage-order", |
| "shadow-compatible-local", "shadow-local", |
| "sized-deallocation", "sizeof-pointer-div", "stack-usage", |
| "strict-null-sentinel", "stringop-overflow", |
| "stringop-truncation", "subobject-linkage", |
| "suggest-attribute", "suggest-final-methods", |
| "suggest-final-types", "suggest-override", "surprising", |
| "switch-unreachable", "sync-nand", "tabs", |
| "target-lifetime", "templates", "terminate", "traditional", |
| "traditional-conversion", "trampolines", |
| "undefined-do-loop", "underflow", |
| "unsafe-loop-optimizations", "unsuffixed-float-constants", |
| "unused-but-set-parameter", "unused-but-set-variable", |
| "unused-dummy-argument", "use-without-only", |
| "useless-cast", "vector-operation-performance", |
| "virtual-inheritance", "virtual-move-assign", |
| "vla-larger-than", "zerotrip") |
| pat3 <- paste0("^\\s*#pragma (GCC|clang) diagnostic[^-]*[-]W(", |
| paste(nonport, collapse="|"), ")") |
| for(f in ff) { |
| if(any(grepl(pat, readLines(f, warn = FALSE), |
| perl = TRUE, useBytes = TRUE))) |
| found <- c(found, f) |
| else next |
| if(any(grepl(pat2, readLines(f, warn = FALSE), |
| perl = TRUE, useBytes = TRUE))) |
| warn <- c(warn, f) |
| if(any(grepl(pat3, readLines(f, warn = FALSE), |
| perl = TRUE, useBytes = TRUE))) |
| port <- c(port, f) |
| } |
| structure(found, class = "check_pragmas", warn = warn, port = port) |
| } |
| |
| print.check_pragmas <- |
| function(x, ...) |
| { |
| if(length(x)) { |
| if(length(x) == 1L) |
| writeLines("File which contain pragma(s) suppressing diagnostics:") |
| else |
| writeLines("Files which contain pragma(s) suppressing diagnostics:") |
| .pretty_print(x) |
| } |
| x |
| } |
| |
| ### ** .check_S3_methods_needing_delayed_registration |
| |
| .check_S3_methods_needing_delayed_registration <- |
| function(package, lib.loc = NULL) |
| { |
| mat <- matrix(character(), 0L, 3L, |
| dimnames = list(NULL, |
| c("Package", "Generic", "Method"))) |
| out <- list(mat = mat, bad = character()) |
| class(out) <- "check_S3_methods_needing_delayed_registration" |
| |
| if(length(package) != 1L) |
| stop("argument 'package' must be of length 1") |
| dir <- find.package(package, lib.loc) |
| if(!dir.exists(file.path(dir, "R"))) return |
| db <- .read_description(file.path(dir, "DESCRIPTION")) |
| suggests <- unname(.get_requires_from_package_db(db, "Suggests")) |
| |
| if(!length(suggests)) return |
| |
| if(basename(package) != "base") |
| .load_package_quietly(package, dirname(dir)) |
| ok <- vapply(suggests, requireNamespace, quietly = TRUE, |
| FUN.VALUE = NA) |
| out$bad <- suggests[!ok] |
| |
| suggests <- suggests[ok] |
| generics <- lapply(suggests, .get_S3_generics_in_ns_exports) |
| |
| packages <- rep.int(suggests, lengths(generics)) |
| generics <- unlist(generics, use.names = FALSE) |
| |
| code_env <- .package_env(package) |
| objects_in_code <- sort(names(code_env)) |
| functions_in_code <- |
| Filter(function(f) is.function(code_env[[f]]), |
| objects_in_code) |
| |
| ## Look only at the *additional* generics in suggests. |
| generics <- |
| setdiff(generics, |
| c(Filter(function(f) .is_S3_generic(f, code_env), |
| functions_in_code), |
| .get_S3_generics_as_seen_from_package(dir, |
| TRUE, |
| TRUE), |
| .get_S3_group_generics(), |
| .get_S3_primitive_generics())) |
| |
| methods_stop_list <- nonS3methods(basename(dir)) |
| methods <- lapply(generics, |
| function(g) { |
| i <- startsWith(functions_in_code, |
| paste0(g, ".")) |
| setdiff(functions_in_code[i], |
| methods_stop_list) |
| }) |
| len <- lengths(methods) |
| ind <- (len > 0L) |
| |
| if(!any(ind)) return(out) |
| |
| len <- len[ind] |
| out$mat <- |
| cbind(Package = rep.int(packages[ind], len), |
| Generic = rep.int(generics[ind], len), |
| Method = unlist(methods[ind], use.names = FALSE)) |
| out |
| } |
| |
| format.check_S3_methods_needing_delayed_registration <- |
| function(x, ...) |
| { |
| c(character(), |
| if(length(bad <- x$bad)) { |
| c("Suggested packages not available for checking:", |
| strwrap(paste(bad, collapse = " "), indent = 2L)) |
| }, |
| if(length(mat <- x$mat)) { |
| c("Apparent S3 methods needing delayed registration:", |
| sprintf(" %s %s %s", |
| format(c("Package", mat[, 1L])), |
| format(c("Generic", mat[, 2L])), |
| format(c("Method", mat[, 3L]))) |
| ) |
| }) |
| } |
| |
| .get_S3_generics_in_ns_exports <- |
| function(ns) |
| { |
| env <- asNamespace(ns) |
| nms <- sort(intersect(names(env), getNamespaceExports(env))) |
| .get_S3_generics_in_env(env, nms) |
| } |
| |
| |
| ### Local variables: *** |
| ### mode: outline-minor *** |
| ### outline-regexp: "### [*]+" *** |
| ### End: *** |
