1# File src/library/tools/R/QC.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2021 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19## R CMD check uses 20## .find_charset 21## .check_namespace 22## .check_package_depends 23## .check_demo_index 24## .check_vignette_index 25## .check_package_subdirs 26## .check_citation 27## .check_package_ASCII_code 28## .check_package_code_syntax 29## .check_packages_used 30## .check_package_code_shlib 31## .check_package_code_startup_functions 32## .check_package_code_assign_to_globalenv 33## .check_package_code_attach 34## .check_package_code_data_into_globalenv 35## .check_code_usage_in_package 36## .check_bogus_return 37## .check_dotInternal 38## .check_package_parseRd 39## .check_Rd_xrefs 40## undoc 41## codoc 42## codocData 43## codocClasses 44## checkDocFiles 45## checkDocStyle 46## checkFF 47## checkS3methods 48## checkReplaceFuns 49## .check_package_datasets 50## .check_package_compact_datasets 51## .check_package_compact_sysdata 52## .check_make_vars 53## .createExdotR (testing.R) 54## .runPackageTestsR (testing.R) 55## .get_LaTeX_errors_from_log_file 56## .check_package_CRAN_incoming 57## checkRdContents 58 59## R CMD build uses .check_package_subdirs 60 61## NB: 'tools' cannot use NAMESPACE imports from utils, as it exists first 62 63## "The language elements" : all are .Primitive *and* print as .Primitive("...") 64langElts <- c("(", "{", ":", "~", 65 "<-", "<<-", "=", 66 "[", "[[", "[[<-", "[<-", "@", "@<-", "$", "$<-", 67 "&&", "||", 68 "break", "for", "function", "if", "next", "repeat", "return", "while") 69 70## Code "existing conceptually" in base, 71## typically function names of default methods for .Primitive s: 72conceptual_base_code <- c("c.default") 73 74##' a "default" print method (see NAMESPACE): 75.print.via.format <- function(x, ...) { 76 writeLines(format(x, ...)) 77 invisible(x) 78} 79 80## utility for whether Rd sources are available. 81.haveRds <- function(dir) 82{ 83 ## either source package or pre-2.10.0 installed package 84 dir.exists (file.path(dir, "man")) || 85 file.exists(file.path(dir, "help", "paths.rds")) 86} 87 88### * undoc/F/out 89 90undoc <- 91function(package, dir, lib.loc = NULL) 92{ 93 ## Argument handling. 94 ## <NOTE> 95 ## Earlier versions used to give an error if there were no Rd 96 ## objects. This is not right: if there is code or data but no 97 ## documentation, everything is undocumented ... 98 ## </NOTE> 99 if(!missing(package)) { 100 if(length(package) != 1L) 101 stop("argument 'package' must be of length 1") 102 dirdir <- dirname(dir <- find.package(package, lib.loc)) 103 ## Using package installed in @code{dir} ... 104 is_base <- package == "base" 105 106 all_doc_topics <- Rd_aliases(package, lib.loc = dirdir) 107 108 ## Load package into code_env. 109 if(!is_base) 110 .load_package_quietly(package, lib.loc) 111 code_env <- .package_env(package) 112 113 code_objs <- ls(envir = code_env, all.names = TRUE) 114 pkgname <- package 115 } 116 else { 117 if(missing(dir)) 118 stop("you must specify 'package' or 'dir'") 119 pkgname <- basename(dir) 120 dirdir <- dirname(dir) 121 ## Using sources from directory @code{dir} ... 122 if(!dir.exists(dir)) 123 stop(gettextf("directory '%s' does not exist", dir), 124 domain = NA) 125 else 126 dir <- file_path_as_absolute(dir) 127 is_base <- pkgname == "base" 128 129 all_doc_topics <- Rd_aliases(dir = dir) 130 131 code_env <- new.env(hash = TRUE) 132 code_dir <- file.path(dir, "R") 133 if(dir.exists(code_dir)) { 134 dfile <- file.path(dir, "DESCRIPTION") 135 meta <- if(file_test("-f", dfile)) 136 .read_description(dfile) 137 else 138 character() 139 .source_assignments_in_code_dir(code_dir, code_env, meta) 140 sys_data_file <- file.path(code_dir, "sysdata.rda") 141 if(file_test("-f", sys_data_file)) 142 load(sys_data_file, code_env) 143 } 144 145 code_objs <- ls(envir = code_env, all.names = TRUE) 146 147 ## Does the package have a NAMESPACE file? Note that when 148 ## working on the sources we (currently?) cannot deal with the 149 ## (experimental) alternative way of specifying the namespace. 150 if(file.exists(file.path(dir, "NAMESPACE"))) { 151 nsInfo <- parseNamespaceFile(pkgname, dirdir) 152 ## Look only at exported objects (and not declared S3 153 ## methods). 154 OK <- intersect(code_objs, nsInfo$exports) 155 for(p in nsInfo$exportPatterns) 156 OK <- c(OK, grep(p, code_objs, value = TRUE)) 157 code_objs <- unique(OK) 158 } 159 } 160 161 ## Find the data sets to work on. 162 data_dir <- file.path(dir, "data") 163 data_objs <- if(dir.exists(data_dir)) 164 unlist(.try_quietly(list_data_in_pkg(dir = dir)), 165 use.names = FALSE) 166 else 167 character() 168 169 ## There was a time when packages contained code or data (or both). 170 ## But not anymore ... 171 if(!missing(package) && !length(code_objs) && !length(data_objs) 172 && getOption("verbose")) 173 message("neither code nor data objects found") 174 175 if(!is_base) { 176 ## Code objects in add-on packages with names starting with a 177 ## dot are considered 'internal' (not user-level) by 178 ## convention. 179 code_objs <- grep("^[^.].*", code_objs, value = TRUE) 180 ## Note that this also allows us to get rid of S4 meta objects 181 ## (with names starting with '.__C__' or '.__M__'; well, as long 182 ## as there are none in base). 183 184 ## Implicit generic functions exist to turn method dispatch on 185 ## in this package, but their definition and documentation belongs 186 ## to the package in their package slot, so eliminate any 187 ## foreign generic functions from code_objs 188 if(.isMethodsDispatchOn()) { 189 is <- methods::is # speed 190 code_objs <- 191 Filter(function(f) { 192 fdef <- code_env[[f]] # faster than get() 193 ## Running methods::is() on data sets can trigger 194 ## loading additional packages for which startup 195 ## messages et al need suppressing ... 196 if(suppressMessages(is(fdef, "genericFunction"))) 197 fdef@package == pkgname 198 else 199 TRUE 200 }, 201 code_objs) 202 } 203 204 ## Allow group generics to be undocumented other than in base. 205 ## In particular, those from methods partially duplicate base 206 ## and are documented in base's groupGenerics.Rd. 207 code_objs <- setdiff(code_objs, 208 c("Arith", "Compare", "Complex", "Logic", 209 "Math", "Math2", "Ops", "Summary")) 210 } 211 212 undoc_things <- 213 list("code objects" = 214 unique(setdiff(code_objs, all_doc_topics)), 215 "data sets" = 216 unique(setdiff(data_objs, all_doc_topics))) 217 218 if(.isMethodsDispatchOn()) { 219 ## Undocumented S4 classes? 220 S4_classes <- methods::getClasses(code_env) 221 ## <NOTE> 222 ## There is no point in worrying about exportClasses directives 223 ## in a NAMESPACE file when working on a package source dir, as 224 ## we only source the assignments, and hence do not get any 225 ## S4 classes or methods. 226 ## </NOTE> 227 ## The bad ones: 228 S4_classes <- 229 S4_classes[vapply(S4_classes, utils:::topicName, " ", 230 type = "class", USE.NAMES = FALSE) 231 %notin% all_doc_topics] 232 undoc_things <- 233 c(undoc_things, list("S4 classes" = unique(S4_classes))) 234 } 235 236 if(.isMethodsDispatchOn()) { 237 ## Undocumented S4 methods? 238 ## <NOTE> 239 ## There is no point in worrying about exportMethods directives 240 ## in a NAMESPACE file when working on a package source dir, as 241 ## we only source the assignments, and hence do not get any 242 ## S4 classes or methods. 243 ## </NOTE> 244 .make_S4_method_siglist <- function(g) { 245 mlist <- .get_S4_methods_list(g, code_env) 246 sigs <- .make_siglist(mlist) # s/#/,/g 247 if(length(sigs)) 248 paste0(g, ",", sigs) 249 else 250 character() 251 } 252 S4_methods <- lapply(.get_S4_generics(code_env), 253 .make_S4_method_siglist) 254 S4_methods <- as.character(unlist(S4_methods, use.names = FALSE)) 255 256 ## The bad ones: 257 S4_methods <- 258 S4_methods[vapply(S4_methods, utils:::topicName, " ", 259 type="method", USE.NAMES = FALSE) 260 %notin% all_doc_topics] 261 undoc_things <- 262 c(undoc_things, 263 list("S4 methods" = 264 unique(sub("([^,]*),(.*)", 265 "generic '\\1' and siglist '\\2'", 266 S4_methods)))) 267 } 268 if(is_base) { 269 ## We use .ArgsEnv and .GenericArgsEnv in checkS3methods() and 270 ## codoc(), so we check here that the set of primitives has not 271 ## been changed. 272 ff <- as.list(baseenv(), all.names=TRUE) 273 prims <- names(ff)[vapply(ff, is.primitive, logical(1L))] 274 prototypes <- sort(c(names(.ArgsEnv), names(.GenericArgsEnv))) 275 extras <- setdiff(prototypes, prims) 276 if(length(extras)) 277 undoc_things <- c(undoc_things, list(prim_extra=extras)) 278 miss <- setdiff(prims, c(langElts, prototypes)) 279 if(length(miss)) 280 undoc_things <- c(undoc_things, list(primitives=miss)) 281 } 282 283 class(undoc_things) <- "undoc" 284 undoc_things 285} 286 287format.undoc <- 288function(x, ...) 289{ 290 .fmt <- function(i) { 291 tag <- names(x)[i] 292 msg <- switch(tag, 293 "code objects" = 294 gettext("Undocumented code objects:"), 295 "data sets" = 296 gettext("Undocumented data sets:"), 297 "S4 classes" = 298 gettext("Undocumented S4 classes:"), 299 "S4 methods" = 300 gettext("Undocumented S4 methods:"), 301 prim_extra = 302 gettext("Prototyped non-primitives:"), 303 gettextf("Undocumented %s:", tag)) 304 c(msg, 305 ## We avoid markup for indicating S4 methods, hence need to 306 ## special-case output for these ... 307 if(tag == "S4 methods") { 308 strwrap(x[[i]], indent = 2L, exdent = 4L) 309 } else { 310 .pretty_format(x[[i]]) 311 }) 312 } 313 314 as.character(unlist(lapply(which(lengths(x) > 0L), .fmt))) 315} 316 317### * codoc 318 319## 320is_data_for_dataset <- function(e) ## trigger for data(foo) or data(foo, package="bar") and similar 321 length(e) >= 2L && e[[1L]] == quote(data) && e[[2L]] != quote(...) && length(e) <= 4L 322 323codoc <- 324function(package, dir, lib.loc = NULL, 325 use.values = NULL, verbose = getOption("verbose")) 326{ 327 has_namespace <- FALSE 328 329 ## Argument handling. 330 if(!missing(package)) { 331 if(length(package) != 1L) 332 stop("argument 'package' must be of length 1") 333 dir <- find.package(package, lib.loc) 334 ## Using package installed in @code{dir} ... 335 code_dir <- file.path(dir, "R") 336 if(!dir.exists(code_dir)) 337 stop(gettextf("directory '%s' does not contain R code", dir), 338 domain = NA) 339 if(!.haveRds(dir)) 340 stop(gettextf("directory '%s' does not contain Rd objects", dir), 341 domain = NA) 342 is_base <- basename(dir) == "base" 343 344 ## Load package into code_env. 345 if(!is_base) 346 .load_package_quietly(package, lib.loc) 347 code_env <- .package_env(package) 348 349 objects_in_code <- sort(names(code_env)) 350 351 dirdir <- dirname(dir) 352 ## Does the package have a namespace? 353 if(packageHasNamespace(package, dirdir)) { 354 has_namespace <- TRUE 355 ns_env <- asNamespace(package) 356 S3Table <- get(".__S3MethodsTable__.", envir = ns_env) 357 functions_in_S3Table <- ls(S3Table, all.names = TRUE) 358 objects_in_ns <- 359 setdiff(sort(names(ns_env)), 360 c(".__NAMESPACE__.", ".__S3MethodsTable__.")) 361 ns_S3_methods_db <- getNamespaceInfo(package, "S3methods") 362 ns_S3_methods <- if(is.null(ns_S3_methods_db)) 363 character() 364 else 365 paste(ns_S3_methods_db[, 1L], 366 ns_S3_methods_db[, 2L], 367 sep = ".") 368 objects_in_code_or_namespace <- 369 unique(c(objects_in_code, objects_in_ns, ns_S3_methods)) 370 objects_in_ns <- setdiff(objects_in_ns, objects_in_code) 371 } 372 else { ## typically only 'base' 373 objects_in_code_or_namespace <- objects_in_code 374 } 375 package_name <- package 376 } 377 else { 378 if(missing(dir)) 379 stop("you must specify 'package' or 'dir'") 380 ## Using sources from directory @code{dir} ... 381 if(!dir.exists(dir)) 382 stop(gettextf("directory '%s' does not exist", dir), domain = NA) 383 ## else 384 package_name <- basename(dir) # early, before resolving sym.links etc in next line: 385 dirdir <- dirname(dir) # early, ... 386 dir <- file_path_as_absolute(dir) 387 code_dir <- file.path(dir, "R") 388 if(!dir.exists(code_dir)) 389 stop(gettextf("directory '%s' does not contain R code", dir), 390 domain = NA) 391 if(!.haveRds(dir)) 392 stop(gettextf("directory '%s' does not contain Rd objects", dir), 393 domain = NA) 394 is_base <- package_name == "base" 395 396 code_env <- new.env(hash = TRUE) 397 dfile <- file.path(dir, "DESCRIPTION") 398 meta <- if(file_test("-f", dfile)) .read_description(dfile) else character() 399 .source_assignments_in_code_dir(code_dir, code_env, meta) 400 sys_data_file <- file.path(code_dir, "sysdata.rda") 401 if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) 402 403 objects_in_code <- sort(names(code_env)) 404 objects_in_code_or_namespace <- objects_in_code 405 406 ## Does the package have a NAMESPACE file? Note that when 407 ## working on the sources we (currently?) cannot deal with the 408 ## (experimental) alternative way of specifying the namespace. 409 ## Also, do not attempt to find S3 methods. 410 if(file.exists(file.path(dir, "NAMESPACE"))) { 411 has_namespace <- TRUE 412 objects_in_ns <- objects_in_code 413 functions_in_S3Table <- character() 414 ns_env <- code_env 415 nsInfo <- parseNamespaceFile(package_name, dirdir) 416 ## Look only at exported objects. 417 OK <- intersect(objects_in_code, nsInfo$exports) 418 for(p in nsInfo$exportPatterns) 419 OK <- c(OK, grep(p, objects_in_code, value = TRUE)) 420 objects_in_code <- unique(OK) 421 } 422 } 423 424 ## Find the data sets to work on. 425 data_dir <- file.path(dir, "data") 426 if(dir.exists(data_dir)) { 427 data_sets_in_code_variables <- 428 .try_quietly(list_data_in_pkg(dir = dir)) 429 data_sets_in_code <- names(data_sets_in_code_variables) 430 } else 431 data_sets_in_code <- data_sets_in_code_variables <- character() 432 433 ## Find the function objects to work on. 434 functions_in_code <- 435 Filter(function(f) { 436 ## This is expensive 437 f <- get(f, envir = code_env) 438 typeof(f) == "closure" 439 }, 440 objects_in_code) 441 ## Sourcing all R code files in the package is a problem for base, 442 ## where this misses the .Primitive functions. Hence, when checking 443 ## base for objects shown in \usage but missing from the code, we 444 ## get the primitive functions from the version of R we are using. 445 ## Maybe one day we will have R code for the primitives as well ... 446 ## As from R 2.5.0 we do for most generics. 447 if(is_base) { 448 objects_in_base <- 449 sort(names(baseenv())) 450 objects_in_code <- 451 c(objects_in_code, 452 conceptual_base_code, 453 Filter(.is_primitive_in_base, objects_in_base), 454 c(".First.lib", ".Last.lib", ".Random.seed", 455 ".onLoad", ".onAttach", ".onDetach", ".onUnload")) 456 objects_in_code_or_namespace <- objects_in_code 457 known_env <- .make_S3_primitive_generic_env(code_env, fixup=TRUE) 458 extras <- ls(known_env, all.names = TRUE) 459 functions_in_code <- c(functions_in_code, extras) 460 code_env <- known_env 461 known_env <- .make_S3_primitive_nongeneric_env(code_env) 462 extras <- ls(known_env, all.names = TRUE) 463 functions_in_code <- c(functions_in_code, extras) 464 code_env <- known_env 465 } 466 467 ## Build a list with the formals of the functions in the code 468 ## indexed by the names of the functions. 469 function_args_in_code <- 470 lapply(functions_in_code, 471 function(f) formals(get(f, envir = code_env))) # get is expensive 472 names(function_args_in_code) <- functions_in_code 473 if(has_namespace) { 474 functions_in_ns <- 475 Filter(function(f) { 476 f <- get(f, envir = ns_env) # get is expensive 477 is.function(f) && (length(formals(f)) > 0L) 478 }, 479 objects_in_ns) 480 function_args_in_ns <- 481 lapply(functions_in_ns, 482 function(f) formals(get(f, envir = ns_env))) 483 names(function_args_in_ns) <- functions_in_ns 484 485 function_args_in_S3Table <- 486 lapply(functions_in_S3Table, 487 function(f) formals(get(f, envir = S3Table))) 488 names(function_args_in_S3Table) <- functions_in_S3Table 489 490 tmp <- c(function_args_in_code, function_args_in_S3Table, 491 function_args_in_ns) 492 keep <- !duplicated(names(tmp)) 493 function_args_in_code <- tmp[keep] 494 functions_in_code <- names(function_args_in_code) 495 } 496 if(.isMethodsDispatchOn()) { 497 ## <NOTE> 498 ## There is no point in worrying about exportMethods directives 499 ## in a NAMESPACE file when working on a package source dir, as 500 ## we only source the assignments, and hence do not get any 501 ## S4 classes or methods. 502 ## </NOTE> 503 ## <NOTE> 504 ## In principle, we can get codoc checking for S4 methods 505 ## documented explicitly using the \S4method{GENERIC}{SIGLIST} 506 ## markup by adding the corresponding "pseudo functions" using 507 ## the Rd markup as their name. However note that the formals 508 ## recorded in the methods db only pertain to the signature, not 509 ## to the ones of the function actually registered ... hence we 510 ## use methods::unRematchDefinition() which knows how to extract 511 ## the formals in the method definition from the 512 ## function(ARGLIST) { 513 ## .local <- function(FORMALS) BODY 514 ## .local(ARGLIST) 515 ## } 516 ## redefinitions obtained by methods::rematchDefinition(). 517 ## </NOTE> 518 check_S4_methods <- 519 !isFALSE(as.logical(Sys.getenv("_R_CHECK_CODOC_S4_METHODS_"))) 520 if(check_S4_methods) { 521 unRematchDef <- methods::unRematchDefinition 522 get_formals_from_method_definition <- function(m) 523 formals(unRematchDef(m)) 524 lapply(.get_S4_generics(code_env), 525 function(f) { 526 mlist <- .get_S4_methods_list(f, code_env) 527 sigs <- .make_siglist(mlist) 528 if(!length(sigs)) return() 529 nm <- sprintf("\\S4method{%s}{%s}", f, sigs) 530 args <- lapply(mlist, 531 get_formals_from_method_definition) 532 names(args) <- nm 533 functions_in_code <<- 534 c(functions_in_code, nm) 535 function_args_in_code <<- 536 c(function_args_in_code, args) 537 }) 538 } 539 } 540 541 check_codoc <- function(fName, ffd) { 542 ## Compare the formals of the function in the code named 'fName' 543 ## and formals 'ffd' obtained from the documentation. 544 ffc <- function_args_in_code[[fName]] 545 ident <- if(isFALSE(use.values)) { 546 ffc <- names(ffc) 547 ffd <- names(ffd) 548 identical(ffc, ffd) 549 } else { 550 identical(names(ffc), names(ffd)) && 551 { 552 vffc <- as.character(ffc) # values 553 vffd <- as.character(ffd) # values 554 if(!isTRUE(use.values)) { 555 ind <- nzchar(vffd) 556 vffc <- vffc[ind] 557 vffd <- vffd[ind] 558 } 559 identical(vffc, vffd) 560 } 561 } 562 if(!ident) 563 list(list(name = fName, code = ffc, docs = ffd)) 564 } #{check_codoc} 565 566 db <- if(!missing(package)) 567 Rd_db(package, lib.loc = dirdir) 568 else 569 Rd_db(dir = dir) 570 571 names(db) <- db_names <- .Rd_get_names_from_Rd_db(db) 572 573 ## pkg-defunct.Rd is not expected to list arguments 574 ind <- db_names %in% paste0(package_name, "-defunct") 575 db <- db[!ind] 576 db_names <- db_names[!ind] 577 578 db_usages <- lapply(db, .Rd_get_section, "usage") 579 ## FIXME: all db_usages entries are full of "srcref" which are never used 580 db_usages <- lapply(db_usages, .parse_usage_as_much_as_possible) 581 ind <- vapply(db_usages, 582 function(x) !is.null(attr(x, "bad_lines")), NA, USE.NAMES=FALSE) 583 bad_lines <- lapply(db_usages[ind], attr, "bad_lines") 584 585 bad_doc_objects <- list() 586 functions_in_usages <- character() 587 variables_in_usages <- character() 588 data_sets_in_usages <- character() 589 functions_in_usages_not_in_code <- list() 590 data_sets_in_usages_not_in_code <- list() 591 variables_in_usages_not_in_code <- list() 592 objects_as_in <- c(objects_in_code_or_namespace 593 , names(compatibilityEnv()) # objects in other platforms 594 , if(missing(package) && str_parse_logic(meta["LazyData"], FALSE)) 595 unlist(data_sets_in_code_variables, use.names = FALSE) 596 , if(is_base) 597 c("NA", "NULL", "Inf", "NaN", "TRUE", "FALSE", ".Autoloaded") 598 ) 599 600 for(docObj in db_names) { 601 exprs <- db_usages[[docObj]] 602 if(!length(exprs)) next 603 604 ## Get variable names and data set usages first, mostly for 605 ## curiosity. 606 ind <- vapply(exprs, is.name, NA, USE.NAMES=FALSE) 607 if(any(ind)) { 608 variables <- sapply(exprs[ind], deparse) 609 variables_in_usages <- c(variables_in_usages, variables) 610 variables <- setdiff(variables, objects_as_in) 611 if(length(variables)) 612 variables_in_usages_not_in_code[[docObj]] <- variables 613 exprs <- exprs[!ind] 614 } 615 616 exprs <- exprs[vapply(exprs, is.call, NA, USE.NAMES=FALSE)] 617 618 ind <- vapply(exprs, is_data_for_dataset, NA, USE.NAMES=FALSE) 619 if(any(ind)) { 620 data_sets <- sapply(exprs[ind], 621 function(e) as.character(e[[2L]])) 622 data_sets_in_usages <- c(data_sets_in_usages, data_sets) 623 data_sets <- setdiff(data_sets, data_sets_in_code) 624 if(length(data_sets)) 625 data_sets_in_usages_not_in_code[[docObj]] <- data_sets 626 exprs <- exprs[!ind] 627 } 628 ## Split out replacement function usages. 629 ind <- vapply(exprs, .is_call_from_replacement_function_usage, NA, USE.NAMES=FALSE) 630 replace_exprs <- exprs[ind] 631 exprs <- exprs[!ind] 632 ## Ordinary functions. 633 functions <- vapply(exprs, function(e) as.character(e[[1L]]), "") 634 ## Catch assignments: checkDocFiles() will report these, so drop 635 ## them here. 636 ## And also unary/binary operators 637 ind <- (functions %notin% c("<-", "=", "+", "-")) 638 exprs <- exprs[ind] 639 functions <- functions[ind] 640 functions <- .transform_S3_method_markup(as.character(functions)) 641 ind <- functions %in% functions_in_code 642 bad_functions <- 643 mapply(functions[ind], 644 exprs[ind], 645 FUN = function(x, y) 646 check_codoc(x, as.pairlist(as.alist.call(y[-1L]))), 647 SIMPLIFY = FALSE) 648 ## Replacement functions. 649 if(length(replace_exprs)) { 650 replace_funs <- 651 paste0(sapply(replace_exprs, 652 function(e) as.character(e[[2L]][[1L]])), 653 "<-") 654 replace_funs <- .transform_S3_method_markup(replace_funs) 655 functions <- c(functions, replace_funs) 656 ind <- (replace_funs %in% functions_in_code) 657 if(any(ind)) { 658 bad_replace_funs <- 659 mapply(replace_funs[ind], 660 replace_exprs[ind], 661 FUN = function(x, y) 662 check_codoc(x, 663 as.pairlist(c(as.alist.call(y[[2L]][-1L]), 664 as.alist.symbol(y[[3L]])))), 665 SIMPLIFY = FALSE) 666 bad_functions <- 667 c(bad_functions, bad_replace_funs) 668 } 669 } 670 671 bad_functions <- do.call("c", bad_functions) 672 if(length(bad_functions)) 673 bad_doc_objects[[docObj]] <- bad_functions 674 675 ## Determine functions with a \usage entry in the documentation 676 ## but 'missing from the code'. If a package has a namespace, we 677 ## really need to look at all objects in the namespace (hence 678 ## 'objects_as_in' contains 'objects_in_code_or_namespace'), 679 ## as one can access the internal 680 ## symbols via ':::' and hence package developers might want to 681 ## provide function usages for some of the internal functions. 682 ## <FIXME> 683 ## We may still have \S4method{}{} entries in functions, which 684 ## cannot have a corresponding object in the code. Hence, we 685 ## remove these function entries, but should really do better, 686 ## by comparing the explicit \usage entries for S4 methods to 687 ## what is actually in the code. We most likely also should do 688 ## something similar for S3 methods. 689 ind <- grepl(.S4_method_markup_regexp, functions) 690 if(any(ind)) 691 functions <- functions[!ind] 692 ## </FIXME> 693 bad_functions <- setdiff(functions, objects_as_in) 694 if(length(bad_functions)) 695 functions_in_usages_not_in_code[[docObj]] <- bad_functions 696 697 functions_in_usages <- c(functions_in_usages, functions) 698 } 699 700 ## Determine (function) objects in the code without a \usage entry. 701 ## Of course, these could still be 'documented' via \alias. 702 ## </NOTE> 703 ## Older versions only printed this information without returning it 704 ## (in case 'verbose' was true). We now add this as an attribute to 705 ## the bad_doc_objects returned. 706 ## </NOTE> 707 objects_in_code_not_in_usages <- 708 setdiff(objects_in_code, 709 c(functions_in_usages, variables_in_usages)) 710 functions_in_code_not_in_usages <- 711 intersect(functions_in_code, objects_in_code_not_in_usages) 712 ## (Note that 'functions_in_code' does not necessarily contain all 713 ## (exported) functions in the package.) 714 715 ## Determine functions which have no usage but really should have. 716 ## If there is no namespace (including base), we have no idea. 717 ## If there is one, everything "exported" (in the package env) 718 ## should also have a \usage, apart from 719 ## * Defunct functions 720 ## * S4 generics. Note that as per R-exts, 721 ## exporting methods on a generic in the namespace will also 722 ## export the generic, and exporting a generic in the namespace 723 ## will also export its methods. 724 ## so it seems there is really no way to figure out whether an 725 ## exported S4 generic should have a \usage entry or not ... 726 functions_missing_from_usages <- 727 if(!has_namespace) character() else { 728 functions <- functions_in_code_not_in_usages 729 if(.isMethodsDispatchOn()) { 730 ## Drop the functions which have S4 methods. 731 functions <- 732 setdiff(functions, names(.get_S4_generics(code_env))) 733 } 734 ## Drop the defunct functions. 735 is_defunct <- function(f) { 736 f <- get(f, envir = code_env) # get is expensive 737 is.function(f) && 738 is.call(b <- body(f)) && 739 identical(as.character(b[[1L]]), ".Defunct") 740 } 741 functions[!vapply(functions, is_defunct, NA, USE.NAMES=FALSE)] 742 } 743 objects_missing_from_usages <- 744 if(!has_namespace) character() else { 745 c(functions_missing_from_usages, 746 setdiff(objects_in_code_not_in_usages, 747 c(functions_in_code, data_sets_in_code))) 748 } 749 750 attr(bad_doc_objects, "objects_in_code_not_in_usages") <- 751 objects_in_code_not_in_usages 752 attr(bad_doc_objects, "functions_in_code_not_in_usages") <- 753 functions_in_code_not_in_usages 754 attr(bad_doc_objects, "functions_in_usages_not_in_code") <- 755 functions_in_usages_not_in_code 756 attr(bad_doc_objects, "function_args_in_code") <- 757 function_args_in_code 758 attr(bad_doc_objects, "data_sets_in_usages_not_in_code") <- 759 data_sets_in_usages_not_in_code 760 if(config_val_to_logical(Sys.getenv("_R_CHECK_CODOC_VARIABLES_IN_USAGES_", 761 "FALSE"))) { 762 attr(bad_doc_objects, "variables_in_usages_not_in_code") <- 763 variables_in_usages_not_in_code 764 } 765 attr(bad_doc_objects, "objects_missing_from_usages") <- 766 objects_missing_from_usages 767 attr(bad_doc_objects, "functions_missing_from_usages") <- 768 functions_missing_from_usages 769 attr(bad_doc_objects, "has_namespace") <- has_namespace 770 attr(bad_doc_objects, "bad_lines") <- bad_lines 771 class(bad_doc_objects) <- "codoc" 772 bad_doc_objects 773} 774 775print.codoc <- 776function(x, ...) 777{ 778 functions_in_usages_not_in_code <- 779 attr(x, "functions_in_usages_not_in_code") 780 if(length(functions_in_usages_not_in_code)) { 781 for(fname in names(functions_in_usages_not_in_code)) { 782 writeLines(gettextf("Functions or methods with usage in documentation object '%s' but not in code:", 783 fname)) 784 .pretty_print(sQuote(unique(functions_in_usages_not_in_code[[fname]]))) 785 writeLines("") 786 } 787 } 788 789 data_sets_in_usages_not_in_code <- 790 attr(x, "data_sets_in_usages_not_in_code") 791 if(length(data_sets_in_usages_not_in_code)) { 792 for(fname in names(data_sets_in_usages_not_in_code)) { 793 writeLines(gettextf("Data with usage in documentation object '%s' but not in code:", 794 fname)) 795 .pretty_print(sQuote(unique(data_sets_in_usages_not_in_code[[fname]]))) 796 writeLines("") 797 } 798 } 799 800 variables_in_usages_not_in_code <- 801 attr(x, "variables_in_usages_not_in_code") 802 if(length(variables_in_usages_not_in_code)) { 803 for(fname in names(variables_in_usages_not_in_code)) { 804 writeLines(gettextf("Variables with usage in documentation object '%s' but not in code:", 805 fname)) 806 .pretty_print(sQuote(unique(variables_in_usages_not_in_code[[fname]]))) 807 writeLines("") 808 } 809 } 810 811 ## In general, functions in the code which only have an \alias but 812 ## no \usage entry are not necessarily a problem---they might be 813 ## mentioned in other parts of the Rd object documenting them, or be 814 ## 'internal'. However, if a package has a namespace, then all 815 ## *exported* functions should have \usage entries (apart from 816 ## defunct functions and S4 generics, see the above comments for 817 ## functions_missing_from_usages). Currently, this information is 818 ## returned in the codoc object but not shown. Eventually, we might 819 ## add something like 820 ## functions_missing_from_usages <- 821 ## attr(x, "functions_missing_from_usages") 822 ## if(length(functions_missing_from_usages)) { 823 ## writeLines("Exported functions without usage information:") 824 ## .pretty_print(functions_in_code_not_in_usages) 825 ## writeLines("") 826 ## } 827 ## similar to the above. 828 829 if(!length(x)) 830 return(invisible(x)) 831 832 has_only_names <- is.character(x[[1L]][[1L]][["code"]]) 833 834 format_args <- function(s) { 835 if(!length(s)) 836 "function()" 837 else if(has_only_names) 838 paste0("function(", paste(s, collapse = ", "), ")") 839 else { 840 s <- paste(deparse(s), collapse = "") 841 s <- gsub(" = ([,\\)])", "\\1", s) 842 s <- gsub("<unescaped bksl>", "\\", s, fixed = TRUE) 843 s <- gsub("^pairlist", "function", s) 844 gsub("^as.pairlist\\(alist\\((.*)\\)\\)$", "function(\\1)", s) 845 } 846 } 847 848 summarize_mismatches_in_names <- function(nfc, nfd) { 849 if(length(nms <- setdiff(nfc, nfd))) 850 writeLines(c(gettext(" Argument names in code not in docs:"), 851 strwrap(paste(nms, collapse = " "), 852 indent = 4L, exdent = 4L))) 853 if(length(nms <- setdiff(nfd, nfc))) 854 writeLines(c(gettext(" Argument names in docs not in code:"), 855 strwrap(paste(nms, collapse = " "), 856 indent = 4L, exdent = 4L))) 857 len <- min(length(nfc), length(nfd)) 858 if(len) { 859 len <- seq_len(len) 860 nfc <- nfc[len] 861 nfd <- nfd[len] 862 ind <- which(nfc != nfd) 863 len <- length(ind) 864 if(len) { 865 if(len > 3L) { 866 writeLines(gettext(" Mismatches in argument names (first 3):")) 867 ind <- ind[1L:3L] 868 } else { 869 writeLines(gettext(" Mismatches in argument names:")) 870 } 871 for(i in ind) { 872 writeLines(sprintf(" Position: %d Code: %s Docs: %s", 873 i, nfc[i], nfd[i])) 874 } 875 } 876 } 877 } 878 879 summarize_mismatches_in_values <- function(ffc, ffd) { 880 ## Be nice, and match arguments by names first. 881 nms <- intersect(names(ffc), names(ffd)) 882 vffc <- ffc[nms] 883 vffd <- ffd[nms] 884 ind <- which(as.character(vffc) != as.character(vffd)) 885 len <- length(ind) 886 if(len) { 887 if(len > 3L) { 888 writeLines(gettext(" Mismatches in argument default values (first 3):")) 889 ind <- ind[1L:3L] 890 } else { 891 writeLines(gettext(" Mismatches in argument default values:")) 892 } 893 for(i in ind) { 894 multiline <- FALSE 895 cv <- deparse(vffc[[i]]) 896 if(length(cv) > 1L) { 897 cv <- paste(cv, collapse = "\n ") 898 multiline <- TRUE 899 } 900 dv <- deparse(vffd[[i]]) 901 if(length(dv) > 1L) { 902 dv <- paste(dv, collapse = "\n ") 903 multiline <- TRUE 904 } 905 dv <- gsub("<unescaped bksl>", "\\", dv, fixed = TRUE) 906 sep <- if(multiline) "\n " else " " 907 writeLines(sprintf(" Name: '%s'%sCode: %s%sDocs: %s", 908 nms[i], sep, cv, sep, dv)) 909 } 910 } 911 } 912 913 summarize_mismatches <- function(ffc, ffd) { 914 if(has_only_names) 915 summarize_mismatches_in_names(ffc, ffd) 916 else { 917 summarize_mismatches_in_names(names(ffc), names(ffd)) 918 summarize_mismatches_in_values(ffc, ffd) 919 } 920 } 921 922 for(fname in names(x)) { 923 writeLines(gettextf("Codoc mismatches from documentation object '%s':", 924 fname)) 925 xfname <- x[[fname]] 926 for(i in seq_along(xfname)) { 927 ffc <- xfname[[i]][["code"]] 928 ffd <- xfname[[i]][["docs"]] 929 writeLines(c(xfname[[i]][["name"]], 930 strwrap(gettextf("Code: %s", format_args(ffc)), 931 indent = 2L, exdent = 17L), 932 strwrap(gettextf("Docs: %s", format_args(ffd)), 933 indent = 2L, exdent = 17L))) 934 summarize_mismatches(ffc, ffd) 935 } 936 writeLines("") 937 } 938 939 invisible(x) 940} 941 942### * codocClasses 943 944codocClasses <- 945function(package, lib.loc = NULL) 946{ 947 ## Compare the 'structure' of S4 classes in an installed package 948 ## between code and documentation. 949 ## Currently, only compares the slot names. 950 951 ## <NOTE> 952 ## This is patterned after the current codoc(). 953 ## It would be useful to return the whole information on class slot 954 ## names found in the code and matching documentation (rather than 955 ## just the ones with mismatches). 956 ## Currently, we only return the names of all classes checked. 957 ## </NOTE> 958 959 bad_Rd_objects <- structure(list(), class = "codocClasses") 960 961 ## Argument handling. 962 if(length(package) != 1L) 963 stop("argument 'package' must be of length 1") 964 dir <- find.package(package, lib.loc) 965 if(!dir.exists(file.path(dir, "R"))) 966 stop(gettextf("directory '%s' does not contain R code", dir), 967 domain = NA) 968 if(!.haveRds(dir)) 969 stop(gettextf("directory '%s' does not contain Rd objects", dir), 970 domain = NA) 971 is_base <- basename(dir) == "base" 972 973 ## Load package into code_env. 974 if(!is_base) 975 .load_package_quietly(package, lib.loc) 976 code_env <- .package_env(package) 977 978 if(!.isMethodsDispatchOn()) 979 return(bad_Rd_objects) 980 981 S4_classes <- methods::getClasses(code_env) 982 if(!length(S4_classes)) return(bad_Rd_objects) 983 984 sApply <- function(X, FUN, ...) ## fast and special case - only 985 unlist(lapply(X = X, FUN = FUN, ...), recursive=FALSE, use.names=FALSE) 986 ## Build Rd data base. 987 db <- Rd_db(package, lib.loc = dirname(dir)) 988 989 ## Need some heuristics now. When does an Rd object document just 990 ## one S4 class so that we can compare (at least) the slot names? 991 ## Try the following: 992 ## 1) \docType{} identical to "class"; 993 ## 2) either exactly one \alias{} or only one ending in "-class" 994 ## 3) a non-empty user-defined section 'Slots'. 995 996 ## As going through the db to extract sections can take some time, 997 ## we do the vectorized metadata computations first, and try to 998 ## subscript whenever possible. 999 1000 idx <- vapply(lapply(db, .Rd_get_doc_type), identical, NA, "class", 1001 USE.NAMES=FALSE) 1002 if(!any(idx)) return(bad_Rd_objects) 1003 db <- db[idx] 1004 stats <- c(n.S4classes = length(S4_classes), n.db = length(db)) 1005 1006 aliases <- lapply(db, .Rd_get_metadata, "alias") 1007 named_class <- lapply(aliases, endsWith, suffix="-class") 1008 nClass <- sApply(named_class, sum) 1009 oneAlias <- lengths(aliases, use.names=FALSE) == 1L 1010 idx <- oneAlias | nClass == 1L 1011 if(!any(idx)) return(bad_Rd_objects) 1012 db <- db[idx] 1013 stats["n.cl"] <- length(db) 1014 1015 ## keep only the foo-class alias in case there was more than one: 1016 multi <- idx & !oneAlias 1017 aliases[multi] <- 1018 mapply(`[`, aliases[multi], named_class[multi], 1019 SIMPLIFY = FALSE, USE.NAMES = FALSE) 1020 aliases <- unlist(aliases[idx], use.names = FALSE) 1021 1022 Rd_slots <- lapply(db, .Rd_get_section, "Slots", FALSE) 1023 idx <- lengths(Rd_slots) > 0L 1024 if(!any(idx)) return(bad_Rd_objects) 1025 db <- db[idx]; aliases <- aliases[idx]; Rd_slots <- Rd_slots[idx] 1026 stats["n.final"] <- length(db) 1027 1028 db_names <- .Rd_get_names_from_Rd_db(db) 1029 1030 .get_slot_names <- function(x) { 1031 ## Get \describe (inside user-defined section 'Slots'): 1032 ## Should this allow for several \describe blocks? 1033 x <- .Rd_get_section(x, "describe") 1034 ## Get the \item tags inside \describe. 1035 txt <- .Rd_get_item_tags(x) 1036 if(!length(txt)) return(character()) 1037 txt <- gsub("\\\\l?dots", "...", txt) 1038 ## And now strip enclosing '\code{...}:' 1039 txt <- gsub("\\\\code\\{([^}]*)\\}:?", "\\1", as.character(txt)) 1040 txt <- unlist(strsplit(txt, ", *")) 1041 trimws(txt) 1042 } 1043 1044 .inheritedSlotNames <- function(ext) { 1045 supcl <- methods::.selectSuperClasses(ext) 1046 unique(unlist(lapply(lapply(supcl, methods::getClassDef), 1047 methods::slotNames), 1048 use.names=FALSE)) 1049 } 1050 1051 S4topics <- vapply(S4_classes, utils:::topicName, " ", 1052 type="class", USE.NAMES=FALSE) 1053 S4_checked <- S4_classes[has.a <- S4topics %in% aliases] 1054 idx <- match(S4topics[has.a], aliases) 1055 for(icl in seq_along(S4_checked)) { 1056 cl <- S4_checked[icl] 1057 cld <- methods::getClass(cl, where = code_env) 1058 ii <- idx[icl] 1059 ## Add sanity checking later ... 1060 scld <- methods::slotNames(cld) 1061 codeSlots <- if(!is.null(scld)) sort(scld) else character() 1062 docSlots <- sort(.get_slot_names(Rd_slots[[ii]])) 1063 superSlots <- .inheritedSlotNames(cld@contains) 1064 if(length(superSlots)) ## allow '\dots' in docSlots 1065 docSlots <- 1066 docSlots[docSlots %notin% c("...", "\\dots")] 1067 ## was if(!identical(slots_in_code, slots_in_docs)) { 1068 if(!all(docSlots %in% codeSlots) || 1069 !all(setdiff(codeSlots, superSlots) %in% docSlots) ) { 1070 bad_Rd_objects[[db_names[ii]]] <- 1071 list(name = cl, 1072 code = codeSlots, 1073 inherited = superSlots, 1074 docs = docSlots) 1075 } 1076 } 1077 1078 attr(bad_Rd_objects, "S4_classes_checked") <- S4_checked 1079 attr(bad_Rd_objects, "stats") <- stats 1080 bad_Rd_objects 1081} ## end{ codocClasses } 1082 1083format.codocClasses <- 1084function(x, ...) 1085{ 1086 .fmt <- function(nm) { 1087 wrapPart <- function(nam) { 1088 capWord <- function(w) sub("\\b(\\w)", "\\U\\1", w, perl = TRUE) 1089 1090 if(length(O <- docObj[[nam]])) 1091 strwrap(sprintf("%s: %s", gettextf(capWord(nam)), 1092 paste(O, collapse = " ")), 1093 indent = 2L, exdent = 8L) 1094 } 1095 1096 docObj <- x[[nm]] 1097 c(gettextf("S4 class codoc mismatches from documentation object '%s':", 1098 nm), 1099 gettextf("Slots for class '%s'", docObj[["name"]]), 1100 wrapPart("code"), 1101 wrapPart("inherited"), 1102 wrapPart("docs"), 1103 "") 1104 } 1105 1106 as.character(unlist(lapply(names(x), .fmt))) 1107} 1108 1109### * codocData 1110 1111codocData <- 1112function(package, lib.loc = NULL) 1113{ 1114 ## Compare the 'structure' of 'data' objects (variables or data 1115 ## sets) in an installed package between code and documentation. 1116 ## Currently, only compares the variable names of data frames found. 1117 1118 ## <NOTE> 1119 ## This is patterned after the current codoc(). 1120 ## It would be useful to return the whole information on data frame 1121 ## variable names found in the code and matching documentation 1122 ## (rather than just the ones with mismatches). 1123 ## Currently, we only return the names of all data frames checked. 1124 ## </NOTE> 1125 1126 bad_Rd_objects <- structure(list(), class = "codocData") 1127 1128 ## Argument handling. 1129 if(length(package) != 1L) 1130 stop("argument 'package' must be of length 1") 1131 1132 dir <- find.package(package, lib.loc) 1133 1134 ## Build Rd data base. 1135 db <- Rd_db(package, lib.loc = dirname(dir)) 1136 1137 is_base <- basename(dir) == "base" 1138 has_namespace <- !is_base && packageHasNamespace(package, dirname(dir)) 1139 1140 ## Load package into code_env. 1141 if(!is_base) 1142 .load_package_quietly(package, lib.loc) 1143 code_env <- .package_env(package) 1144 if(has_namespace) ns_env <- asNamespace(package) 1145 1146 ## Could check here whether the package has any variables or data 1147 ## sets (and return if not). 1148 1149 1150 ## Need some heuristics now. When does an Rd object document a 1151 ## data.frame (could add support for other classes later) variable 1152 ## or data set so that we can compare (at least) the names of the 1153 ## variables in the data frame? Try the following: 1154 ## * just one \alias{}; 1155 ## * if documentation was generated via prompt, there is a \format 1156 ## section starting with 'A data frame with' (but many existing Rd 1157 ## files instead have 'This data frame contains' and containing 1158 ## one or more \describe sections inside. 1159 1160 ## As going through the db to extract sections can take some time, 1161 ## we do the vectorized metadata computations first, and try to 1162 ## subscript whenever possible. 1163 aliases <- lapply(db, .Rd_get_metadata, "alias") 1164 idx <- lengths(aliases) == 1L 1165 if(!any(idx)) return(bad_Rd_objects) 1166 db <- db[idx] 1167 aliases <- aliases[idx] 1168 1169 names(db) <- .Rd_get_names_from_Rd_db(db) 1170 1171 .get_var_names_from_item_tags <- function(s, nice = TRUE) { 1172 if(!length(s)) return(character()) 1173 1174 nms <- character() 1175 ## Handle trailing colons and leading/trailing white space. 1176 s <- sub("^ *", "", sub("( *:)? *$", "", s)) 1177 ## Handle \samp entries: need to match until the first unescaped 1178 ## rbrace. 1179 re <- "\\\\samp\\{(([^\\}]|[\\].)*)\\}( *, *)?" 1180 m <- gregexpr(re, s) 1181 if(any(unlist(m) > -1)) { 1182 nms <- sub(re, "\\1", unlist(regmatches(s, m))) 1183 ## Unescape Rd escapes. 1184 nms <- gsub("\\\\([{}%])", "\\1", nms) 1185 regmatches(s, m) <- "" 1186 } 1187 ## Handle \code entries, assuming that they can be taken literally 1188 ## (no escaping or quoting to obtain valid R syntax). 1189 re <- "\\\\code\\{([^}]*)\\}( *, *)?" 1190 m <- gregexpr(re, s) 1191 add <- regmatches(s, m) 1192 lens <- lengths(add) 1193 add <- sub(re, "\\1", unlist(add)) 1194 ## The old code base simply dropped the \code markup via 1195 ## gsub("\\\\code\\{(.*)\\}:?", "\\1", s) 1196 ## unescaped underscores and stripped whitespace. 1197 ## Let us be nice about such whitespace inside a single \code (by 1198 ## default), as this should always render ok in the manual, but not 1199 ## about escaped underscores e.g., 1200 ## ElemStatLearn/man/marketing.Rd: Dual\_Income 1201 ## and comma-separated lists inside 1202 ## \code, e.g., 1203 ## prefmod/man/trdel.Rd: \code{V1,V2,V3,V4,V5,V6,V7,V8,V9,V10} 1204 ## as these will not render correctly. 1205 if(nice) { 1206 ind <- rep.int(lens == 1L, lens) 1207 add[ind] <- trimws(add[ind]) 1208 } 1209 nms <- c(nms, add) 1210 regmatches(s, m) <- "" 1211 ## Handle rest. 1212 nms <- c(nms, unlist(strsplit(s, " *, *"))) 1213 nms 1214 } 1215 1216 .get_data_frame_var_names <- function(x) { 1217 ## Make sure that there is exactly one format section: 1218 ## using .Rd_get_section() would get the first one. 1219 x <- x[RdTags(x) == "\\format"] 1220 if(length(x) != 1L) return(character()) 1221 ## Drop comments. 1222 ## <FIXME> 1223 ## Remove calling .Rd_drop_comments() eventually. 1224 x <- .Rd_drop_comments(x[[1L]]) 1225 ## </FIXME> 1226 ## What did the format section start with? 1227 if(!grepl("^[ \n\t]*(A|This) data frame", 1228 .Rd_deparse(x, tag = FALSE))) 1229 return(character()) 1230 ## Get \describe inside \format. 1231 ## Should this allow for several \describe blocks? 1232 x <- .Rd_get_section(x, "describe") 1233 ## Get the \item tags inside \describe. 1234 x <- .Rd_get_item_tags(x) 1235 ## And extract the variable names from these. 1236 .get_var_names_from_item_tags(x) 1237 } 1238 1239 Rd_var_names <- lapply(db, .get_data_frame_var_names) 1240 1241 idx <- (lengths(Rd_var_names) > 0L) 1242 if(!length(idx)) return(bad_Rd_objects) 1243 aliases <- unlist(aliases[idx]) 1244 Rd_var_names <- Rd_var_names[idx] 1245 1246 db_names <- names(db)[idx] 1247 1248 data_env <- new.env(hash = TRUE) 1249 data_dir <- file.path(dir, "data") 1250 ## with lazy data we have data() but don't need to use it. 1251 has_data <- dir.exists(data_dir) && 1252 !file_test("-f", file.path(data_dir, "Rdata.rdb")) 1253 data_exts <- .make_file_exts("data") 1254 1255 ## Now go through the aliases. 1256 data_frames_checked <- character() 1257 for(i in seq_along(aliases)) { 1258 ## Store the documented variable names. 1259 var_names_in_docs <- sort(Rd_var_names[[i]]) 1260 ## Try finding the variable or data set given by the alias. 1261 al <- aliases[i] 1262 if(!is.null(A <- get0(al, envir = code_env, mode = "list", inherits = FALSE))) 1263 al <- A 1264 else if(has_namespace && 1265 !is.null(A <- get0(al, envir = ns_env, mode = "list", inherits = FALSE))) 1266 al <- A 1267 else if(has_data) { 1268 ## Should be a data set. 1269 if(!length(dir(data_dir) 1270 %in% paste(al, data_exts, sep = "."))) { 1271 next # What the hell did we pick up? 1272 } 1273 ## Try loading the data set into data_env. 1274 utils::data(list = al, envir = data_env) 1275 if(!is.null(A <- get0(al, envir = data_env, mode = "list", inherits = FALSE))) 1276 al <- A 1277 1278 ## And clean up data_env. 1279 rm(list = ls(envir = data_env, all.names = TRUE), 1280 envir = data_env) 1281 } 1282 if(!is.data.frame(al)) next 1283 ## Now we should be ready: 1284 data_frames_checked <- c(data_frames_checked, aliases[i]) 1285 var_names_in_code <- sort(names(al)) 1286 if(!identical(var_names_in_code, var_names_in_docs)) 1287 bad_Rd_objects[[db_names[i]]] <- 1288 list(name = aliases[i], 1289 code = var_names_in_code, 1290 docs = var_names_in_docs) 1291 } 1292 1293 attr(bad_Rd_objects, "data_frames_checked") <- 1294 as.character(data_frames_checked) 1295 bad_Rd_objects 1296} 1297 1298format.codocData <- 1299function(x, ...) 1300{ 1301 format_args <- function(s) paste(s, collapse = " ") 1302 1303 .fmt <- function(nm) { 1304 docObj <- x[[nm]] 1305 ## FIXME singular or plural? 1306 c(gettextf("Data codoc mismatches from documentation object '%s':", nm), 1307 gettextf("Variables in data frame '%s'", docObj[["name"]]), 1308 strwrap(gettextf("Code: %s", format_args(docObj[["code"]])), 1309 indent = 2L, exdent = 8L), 1310 strwrap(gettextf("Docs: %s", format_args(docObj[["docs"]])), 1311 indent = 2L, exdent = 8L), 1312 "") 1313 } 1314 1315 as.character(unlist(lapply(names(x), .fmt))) 1316} 1317 1318### * checkDocFiles 1319 1320checkDocFiles <- 1321function(package, dir, lib.loc = NULL, chkInternal = FALSE) 1322{ 1323 ## Argument handling. 1324 if(!missing(package)) { 1325 if(length(package) != 1L) 1326 stop("argument 'package' must be of length 1") 1327 dir <- find.package(package, lib.loc) 1328 ## Using package installed in @code{dir} ... 1329 } 1330 else { 1331 if(missing(dir)) 1332 stop("you must specify 'package' or 'dir'") 1333 ## Using sources from directory @code{dir} ... 1334 if(!dir.exists(dir)) 1335 stop(gettextf("directory '%s' does not exist", dir), 1336 domain = NA) 1337 else 1338 dir <- file_path_as_absolute(dir) 1339 } 1340 1341 db <- if(!missing(package)) 1342 Rd_db(package, lib.loc = dirname(dir)) 1343 else 1344 Rd_db(dir = dir) 1345 1346 db_aliases <- lapply(db, .Rd_get_metadata, "alias") 1347 db_keywords <- lapply(db, .Rd_get_metadata, "keyword") 1348 1349 db_names <- .Rd_get_names_from_Rd_db(db) 1350 names(db) <- names(db_aliases) <- db_names 1351 1352 db_usages <- lapply(db, .Rd_get_section, "usage") 1353 ## We traditionally also use the usage "texts" for some sanity 1354 ## checking ... 1355 ## <FIXME> 1356 ## Remove calling .Rd_drop_comments() eventually. 1357 db_usage_texts <- 1358 lapply(db_usages, 1359 function(e) .Rd_deparse(.Rd_drop_comments(e))) 1360 ## </FIXME> 1361 db_usages <- lapply(db_usages, .parse_usage_as_much_as_possible) 1362 ind <- vapply(db_usages, 1363 function(x) !is.null(attr(x, "bad_lines")), 1364 NA) 1365 bad_lines <- lapply(db_usages[ind], attr, "bad_lines") 1366 1367 if(!chkInternal && 1368 any(ind <- vapply(db_keywords, function(x) "internal" %in% x, NA))) { 1369 ## exclude them 1370 db <- db [!ind] 1371 db_names <- db_names [!ind] 1372 db_aliases <- db_aliases[!ind] 1373 } 1374 1375 db_argument_names <- lapply(db, .Rd_get_argument_names) 1376 1377 bad_doc_objects <- list() 1378 1379 for(docObj in db_names) { 1380 1381 exprs <- db_usages[[docObj]] 1382 if(!length(exprs)) next 1383 1384 aliases <- db_aliases[[docObj]] 1385 arg_names_in_arg_list <- db_argument_names[[docObj]] 1386 1387 ## Determine function names ('functions') and corresponding 1388 ## arguments ('arg_names_in_usage') in the \usage. Note how we 1389 ## try to deal with data set documentation. 1390 ind <- vapply(exprs, 1391 function(e) 1392 length(e) > 1L && !is_data_for_dataset(e), 1393 NA, USE.NAMES=FALSE) 1394 exprs <- exprs[ind] 1395 ## Split out replacement function usages. 1396 ind <- vapply(exprs, .is_call_from_replacement_function_usage, 1397 NA, USE.NAMES=FALSE) 1398 replace_exprs <- exprs[ind] 1399 exprs <- exprs[!ind] 1400 ## Ordinary functions. 1401 functions <- as.character(sapply(exprs, 1402 function(e) 1403 as.character(e[[1L]]))) 1404 ## Catch assignments. 1405 ind <- functions %in% c("<-", "=") 1406 assignments <- exprs[ind] 1407 if(any(ind)) { 1408 exprs <- exprs [!ind] 1409 functions <- functions[!ind] 1410 } 1411 ## (Note that as.character(sapply(exprs, "[[", 1L)) does not do 1412 ## what we want due to backquotifying.) 1413 arg_names_in_usage <- 1414 unlist(lapply(exprs, 1415 function(e) .arg_names_from_call(e[-1L]))) 1416 ## Replacement functions. 1417 if(length(replace_exprs)) { 1418 replace_funs <- 1419 paste0(vapply(replace_exprs, 1420 function(e) as.character(e[[2L]][[1L]]), ""), 1421 "<-") 1422 functions <- c(functions, replace_funs) 1423 arg_names_in_usage <- 1424 c(arg_names_in_usage, 1425 unlist(lapply(replace_exprs, 1426 function(e) 1427 c(.arg_names_from_call(e[[2L]][-1L]), 1428 .arg_names_from_call(e[[3L]]))))) 1429 } 1430 ## And finally transform the S3 \method{}{} markup into the 1431 ## usual function names ... 1432 ## <NOTE> 1433 ## If we were really picky, we would worry about possible 1434 ## namespace renaming. 1435 functions <- .transform_S3_method_markup(functions) 1436 ## </NOTE> 1437 ## Also transform the markup for S4 replacement methods. 1438 functions <- .transform_S4_method_markup(functions) 1439 1440 ## Now analyze what we found. 1441 arg_names_in_usage_missing_in_arg_list <- 1442 setdiff(arg_names_in_usage, arg_names_in_arg_list) 1443 arg_names_in_arg_list_missing_in_usage <- 1444 setdiff(arg_names_in_arg_list, arg_names_in_usage) 1445 if(length(arg_names_in_arg_list_missing_in_usage)) { 1446 usage_text <- db_usage_texts[[docObj]] 1447 bad_args <- character() 1448 ## In the case of 'over-documented' arguments, try to be 1449 ## defensive and reduce to arguments which either are not 1450 ## syntactically valid names or do not match the \usage text 1451 ## (modulo word boundaries). 1452 bad <- !grepl("^[[:alnum:]._]+$", 1453 arg_names_in_arg_list_missing_in_usage) 1454 if(any(bad)) { 1455 bad_args <- arg_names_in_arg_list_missing_in_usage[bad] 1456 arg_names_in_arg_list_missing_in_usage <- 1457 arg_names_in_arg_list_missing_in_usage[!bad] 1458 } 1459 bad <- vapply(arg_names_in_arg_list_missing_in_usage, 1460 function(x) 1461 !grepl(paste0("(^|\\W)", 1462 reQuote(x), 1463 "($|\\W)"), 1464 gsub("\\\\dots", "...", 1465 usage_text)), 1466 NA) 1467 arg_names_in_arg_list_missing_in_usage <- 1468 c(bad_args, 1469 arg_names_in_arg_list_missing_in_usage[as.logical(bad)]) 1470 ## Note that the fact that we can parse the raw \usage does 1471 ## not imply that over-documented arguments are a problem: 1472 ## this works for Rd files documenting e.g. shell utilities 1473 ## but fails for files with special syntax (Extract.Rd). 1474 } 1475 1476 ## Also test whether the objects we found from the \usage all 1477 ## have aliases, provided that there is no alias which ends in 1478 ## '-deprecated' (see e.g. base-deprecated.Rd). 1479 functions_not_in_aliases <- 1480 if(!any(endsWith(aliases, "-deprecated"))) { 1481 ## Argh. There are good reasons for keeping \S4method{}{} 1482 ## as is, but of course this is not what the aliases use ... 1483 ## <FIXME> 1484 ## Should maybe use utils:::topicName(), but in any case, we 1485 ## should have functions for converting between the two 1486 ## forms, see also the code for undoc(). 1487 aliases <- sub("([^,]+),(.+)-method$", 1488 "\\\\S4method{\\1}{\\2}", 1489 aliases) 1490 ## </FIXME> 1491 aliases <- gsub("\\%", "%", aliases, fixed=TRUE) 1492 setdiff(functions, aliases) 1493 } 1494 else character() 1495 1496 if((length(arg_names_in_usage_missing_in_arg_list)) 1497 || anyDuplicated(arg_names_in_arg_list) 1498 || (length(arg_names_in_arg_list_missing_in_usage)) 1499 || (length(functions_not_in_aliases)) 1500 || (length(assignments))) 1501 bad_doc_objects[[docObj]] <- 1502 list(missing = arg_names_in_usage_missing_in_arg_list, 1503 duplicated = 1504 arg_names_in_arg_list[duplicated(arg_names_in_arg_list)], 1505 overdoc = arg_names_in_arg_list_missing_in_usage, 1506 unaliased = functions_not_in_aliases, 1507 assignments = assignments) 1508 } # for(..) 1509 1510 structure(bad_doc_objects, class = "checkDocFiles", 1511 "bad_lines" = bad_lines) 1512} 1513 1514format.checkDocFiles <- 1515function(x, ...) 1516{ 1517 .fmt <- function(nm) { 1518 c(character(), 1519 if(length(arg_names_in_usage_missing_in_arg_list <- 1520 x[[nm]][["missing"]])) { 1521 c(gettextf("Undocumented arguments in documentation object '%s'", 1522 nm), 1523 .pretty_format(unique(arg_names_in_usage_missing_in_arg_list))) 1524 }, 1525 if(length(duplicated_args_in_arg_list <- 1526 x[[nm]][["duplicated"]])) { 1527 c(gettextf("Duplicated \\argument entries in documentation object '%s':", 1528 nm), 1529 .pretty_format(duplicated_args_in_arg_list)) 1530 }, 1531 if(length(arg_names_in_arg_list_missing_in_usage <- 1532 x[[nm]][["overdoc"]])) { 1533 c(gettextf("Documented arguments not in \\usage in documentation object '%s':", 1534 nm), 1535 .pretty_format(unique(arg_names_in_arg_list_missing_in_usage))) 1536 }, 1537 if(length(functions_not_in_aliases <- 1538 x[[nm]][["unaliased"]])) { 1539 c(gettextf("Objects in \\usage without \\alias in documentation object '%s':", 1540 nm), 1541 .pretty_format(unique(functions_not_in_aliases))) 1542 }, 1543 if(length(assignments <- 1544 x[[nm]][["assignments"]])) { 1545 c(gettextf("Assignments in \\usage in documentation object '%s':", 1546 nm), 1547 sprintf(" %s", unlist(lapply(assignments, format)))) 1548 }, 1549 "") 1550 } 1551 1552 y <- as.character(unlist(lapply(names(x), .fmt))) 1553 1554 if(length(bad_lines <- attr(x, "bad_lines"))) 1555 y <- c(y, 1556 unlist(lapply(names(bad_lines), 1557 function(nm) { 1558 c(gettextf("Bad \\usage lines found in documentation object '%s':", 1559 nm), 1560 paste0(" ", bad_lines[[nm]])) 1561 })), 1562 "") 1563 1564 y 1565} 1566 1567### * checkDocStyle 1568 1569checkDocStyle <- 1570function(package, dir, lib.loc = NULL) 1571{ 1572 has_namespace <- FALSE 1573 1574 ## Argument handling. 1575 if(!missing(package)) { 1576 if(length(package) != 1L) 1577 stop("argument 'package' must be of length 1") 1578 dir <- find.package(package, lib.loc) 1579 ## Using package installed in 'dir' ... 1580 dfile <- file.path(dir, "DESCRIPTION") 1581 meta <- if(file_test("-f", dfile)) 1582 .read_description(dfile) 1583 else 1584 character() 1585 code_dir <- file.path(dir, "R") 1586 if(!dir.exists(code_dir)) 1587 stop(gettextf("directory '%s' does not contain R code", 1588 dir), 1589 domain = NA) 1590 if(!.haveRds(dir)) 1591 stop(gettextf("directory '%s' does not contain Rd objects", dir), 1592 domain = NA) 1593 package_name <- package 1594 is_base <- package_name == "base" 1595 1596 ## Load package into code_env. 1597 if(!is_base) 1598 .load_package_quietly(package, lib.loc) 1599 code_env <- .package_env(package) 1600 1601 objects_in_code <- sort(names(code_env)) 1602 1603 ## Does the package have a namespace? 1604 ## These days all packages have namespaces, but some are 1605 ## auto-generated. 1606 if(packageHasNamespace(package, dirname(dir))) { 1607 has_namespace <- TRUE 1608 ## Determine names of declared S3 methods and associated S3 1609 ## generics. 1610 ns_S3_methods_db <- getNamespaceInfo(package, "S3methods") 1611 ns_S3_generics <- as.character(ns_S3_methods_db[, 1L]) 1612 ns_S3_methods <- ns_S3_methods_db[, 3L] 1613 if(!is.character(ns_S3_methods)) { 1614 ## As of 2018-07, direct calls to registerS3method() 1615 ## could have registered a function object (not name). 1616 ind <- vapply(ns_S3_methods, is.character, NA) 1617 ns_S3_methods[!ind] <- "" 1618 ns_S3_methods <- as.character(ns_S3_methods) 1619 } 1620 } 1621 } 1622 else { 1623 if(missing(dir)) 1624 stop("you must specify 'package' or 'dir'") 1625 package_name <- basename(dir) # early, before resolving sym.links 1626 ## Using sources from directory @code{dir} ... 1627 if(!dir.exists(dir)) 1628 stop(gettextf("directory '%s' does not exist", dir), 1629 domain = NA) 1630 else 1631 dir <- file_path_as_absolute(dir) 1632 code_dir <- file.path(dir, "R") 1633 if(!dir.exists(code_dir)) 1634 stop(gettextf("directory '%s' does not contain R code", 1635 dir), 1636 domain = NA) 1637 if(!.haveRds(dir)) 1638 stop(gettextf("directory '%s' does not contain Rd objects", dir), 1639 domain = NA) 1640 is_base <- package_name == "base" 1641 1642 code_env <- new.env(hash = TRUE) 1643 dfile <- file.path(dir, "DESCRIPTION") 1644 meta <- if(file_test("-f", dfile)) .read_description(dfile) else character() 1645 .source_assignments_in_code_dir(code_dir, code_env, meta) 1646 sys_data_file <- file.path(code_dir, "sysdata.rda") 1647 if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) 1648 1649 objects_in_code <- sort(names(code_env)) 1650 1651 ## Do the package sources have a NAMESPACE file? 1652 if(file.exists(file.path(dir, "NAMESPACE"))) { 1653 has_namespace <- TRUE 1654 nsInfo <- parseNamespaceFile(package_name, dirname(dir)) 1655 ## Determine exported objects. 1656 OK <- intersect(objects_in_code, nsInfo$exports) 1657 for(p in nsInfo$exportPatterns) 1658 OK <- c(OK, grep(p, objects_in_code, value = TRUE)) 1659 objects_in_code <- unique(OK) 1660 ## Determine names of declared S3 methods and associated S3 1661 ## generics. 1662 ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo) 1663 ns_S3_generics <- ns_S3_methods_db[, 1L] 1664 ns_S3_methods <- ns_S3_methods_db[, 3L] 1665 } 1666 1667 } 1668 1669 ## Find the function objects in the given package. 1670 functions_in_code <- 1671 Filter(function(f) is.function(get(f, envir = code_env)), # get is expensive 1672 objects_in_code) 1673 1674 ## Find all S3 generics "as seen from the package". 1675 all_S3_generics <- 1676 unique(c(Filter(function(f) .is_S3_generic(f, envir = code_env), 1677 functions_in_code), 1678 .get_S3_generics_as_seen_from_package(dir, 1679 !missing(package), 1680 TRUE), 1681 .get_S3_group_generics())) 1682 ## <FIXME> 1683 ## Not yet: 1684 code_env <- .make_S3_group_generic_env(parent = code_env) 1685 ## </FIXME> 1686 1687 ## Find all methods in the given package for the generic functions 1688 ## determined above. Store as a list indexed by the names of the 1689 ## generic functions. 1690 ## Change in 3.0.0: we only look for methods named generic.class, 1691 ## not those registered by a 3-arg S3method(). 1692 methods_stop_list <- nonS3methods(package_name) 1693 methods_in_package <- 1694 Map(function(g) { 1695 ## This isn't really right: it assumes the generics are 1696 ## visible. 1697 if(!exists(g, envir = code_env)) return(character()) 1698 ## <FIXME> 1699 ## We should really determine the name g dispatches for, 1700 ## see a current version of methods() [2003-07-07]. 1701 ## (Care is needed for internal generics and group 1702 ## generics.) 1703 name <- paste0(g, ".") 1704 methods <- 1705 functions_in_code[startsWith(functions_in_code, name)] 1706 ## </FIXME> 1707 methods <- setdiff(methods, methods_stop_list) 1708 if(has_namespace) { 1709 ## Find registered methods for generic g. 1710 methods2 <- ns_S3_methods[ns_S3_generics == g] 1711 ## but for these purposes check name. 1712 OK <- startsWith(methods2, name) 1713 methods <- c(methods, methods2[OK]) 1714 } 1715 methods 1716 }, 1717 all_S3_generics) 1718 all_methods_in_package <- unlist(methods_in_package) 1719 ## There are situations where S3 methods might be documented as 1720 ## functions (i.e., with their full name), if they do something 1721 ## useful also for arguments not inheriting from the class they 1722 ## provide a method for. 1723 ## But then they should be exported under another name, and 1724 ## registered as an S3 method. 1725 ## Prior to 2.14.0 we used to allow this in the case the 1726 ## package has a namespace and the method is exported (even though 1727 ## we strongly prefer using FOO(as.BAR(x)) to FOO.BAR(x) for such 1728 ## cases). 1729 ## But this caused discontinuities with adding namespaces. 1730 ## Historical exception 1731 if(package_name == "cluster") 1732 all_methods_in_package <- 1733 setdiff(all_methods_in_package, functions_in_code) 1734 1735 db <- if(!missing(package)) 1736 Rd_db(package, lib.loc = dirname(dir)) 1737 else 1738 Rd_db(dir = dir) 1739 1740 names(db) <- db_names <- .Rd_get_names_from_Rd_db(db) 1741 1742 ## Ignore pkg-deprecated.Rd and pkg-defunct.Rd. 1743 ind <- db_names %in% paste(package_name, c("deprecated", "defunct"), 1744 sep = "-") 1745 db <- db[!ind] 1746 db_names <- db_names[!ind] 1747 1748 db_usages <- 1749 lapply(db, 1750 function(Rd) { 1751 Rd <- .Rd_get_section(Rd, "usage") 1752 .parse_usage_as_much_as_possible(Rd) 1753 }) 1754 ind <- vapply(db_usages, 1755 function(x) !is.null(attr(x, "bad_lines")), 1756 NA) 1757 bad_lines <- lapply(db_usages[ind], attr, "bad_lines") 1758 1759 bad_doc_objects <- list() 1760 1761 for(docObj in db_names) { 1762 1763 ## Determine function names in the \usage. 1764 exprs <- db_usages[[docObj]] 1765 exprs <- exprs[lengths(exprs) > 1L] 1766 ## Ordinary functions. 1767 functions <- 1768 as.character(sapply(exprs, 1769 function(e) as.character(e[[1L]]))) 1770 ## (Note that as.character(sapply(exprs, "[[", 1L)) does not do 1771 ## what we want due to backquotifying.) 1772 ## Replacement functions. 1773 ind <- vapply(exprs, .is_call_from_replacement_function_usage, NA) 1774 if(any(ind)) { 1775 replace_funs <- 1776 paste0(sapply(exprs[ind], 1777 function(e) as.character(e[[2L]][[1L]])), 1778 "<-") 1779 functions <- c(functions, replace_funs) 1780 } 1781 1782 methods_with_full_name <- 1783 intersect(functions, all_methods_in_package) 1784 1785 functions <- .transform_S3_method_markup(functions) 1786 1787 methods_with_generic <- 1788 Map(function(g) 1789 intersect(functions, methods_in_package[[g]]), 1790 intersect(functions, all_S3_generics)) 1791 1792 if((length(methods_with_generic)) || 1793 (length(methods_with_full_name))) 1794 bad_doc_objects[[docObj]] <- 1795 list(withGeneric = methods_with_generic, 1796 withFullName = methods_with_full_name) 1797 1798 } 1799 1800 attr(bad_doc_objects, "bad_lines") <- bad_lines 1801 class(bad_doc_objects) <- "checkDocStyle" 1802 bad_doc_objects 1803} 1804 1805format.checkDocStyle <- 1806function(x, ...) 1807{ 1808 .fmt <- function(nm) { 1809 ## <NOTE> 1810 ## With \method{GENERIC}{CLASS} now being transformed to show 1811 ## both GENERIC and CLASS info, documenting S3 methods on the 1812 ## same page as their generic is not necessarily a problem any 1813 ## more (as one can refer to the generic or the methods in the 1814 ## documentation, in particular for the primary argument). 1815 ## Hence, even if we still provide information about this, we 1816 ## no longer print it by default. One can still access it via 1817 ## lapply(checkDocStyle("foo"), "[[", "withGeneric") 1818 ## (but of course it does not print that nicely anymore), 1819 ## </NOTE> 1820 methods_with_full_name <- x[[nm]][["withFullName"]] 1821 if(length(methods_with_full_name)) { 1822 c(gettextf("S3 methods shown with full name in documentation object '%s':", 1823 nm), 1824 .pretty_format(methods_with_full_name), 1825 "") 1826 } else { 1827 character() 1828 } 1829 } 1830 1831 as.character(unlist(lapply(names(x), .fmt))) 1832} 1833 1834 1835### * checkFF 1836 1837checkFF <- 1838function(package, dir, file, lib.loc = NULL, 1839 registration = FALSE, check_DUP = FALSE, 1840 verbose = getOption("verbose")) 1841{ 1842 allow_suppress <- !nzchar(Sys.getenv("_R_CHECK_FF_AS_CRAN_")) 1843 suppressCheck <- function(e) 1844 allow_suppress && 1845 length(e) == 2L && is.call(e) && is.symbol(e[[1L]]) && 1846 as.character(e[[1L]]) == "dontCheck" 1847 1848 has_namespace <- FALSE 1849 is_installed_msg <- is_installed <- FALSE 1850 ## Argument handling. 1851 if(!missing(package)) { 1852 if(length(package) != 1L) 1853 stop("argument 'package' must be of length 1") 1854 dir <- find.package(package, lib.loc) 1855 dfile <- file.path(dir, "DESCRIPTION") 1856 db <- .read_description(dfile) 1857 pkg <- pkgDLL <- basename(dir) 1858 ## Using package installed in @code{dir} ... 1859 code_dir <- file.path(dir, "R") 1860 if(!dir.exists(code_dir)) 1861 stop(gettextf("directory '%s' does not contain R code", 1862 dir), 1863 domain = NA) 1864 have_registration <- FALSE 1865 if(basename(dir) != "base") { 1866 .load_package_quietly(package, lib.loc) 1867 code_env <- asNamespace(package) 1868 if(!is.null(DLLs <- get0("DLLs", envir = code_env$.__NAMESPACE__.))) { 1869 ## fake installs have this, of class DLLInfoList 1870 if(length(DLLs)) has_namespace <- TRUE 1871 if(length(DLLs) && inherits(DLLs[[1L]], "DLLInfo")) { 1872 pkgDLL <- unclass(DLLs[[1L]])$name # different for data.table 1873 if(registration) { 1874 reg <- getDLLRegisteredRoutines(DLLs[[1L]]) 1875 have_registration <- sum(lengths(reg)) > 0L 1876 } 1877 } 1878 } 1879 } else { 1880 has_namespace <- have_registration <- TRUE 1881 code_env <-.package_env(package) 1882 } 1883 is_installed <- TRUE 1884 } 1885 else if(!missing(dir)) { 1886 have_registration <- FALSE 1887 ## Using sources from directory @code{dir} ... 1888 if(!dir.exists(dir)) 1889 stop(gettextf("directory '%s' does not exist", dir), 1890 domain = NA) 1891 else 1892 dir <- file_path_as_absolute(dir) 1893 pkg <- pkgDLL <- basename(dir) 1894 dfile <- file.path(dir, "DESCRIPTION") 1895 enc <- NA; db <- NULL 1896 if(file.exists(dfile)) { 1897 db <- .read_description(dfile) 1898 enc <- db["Encoding"] 1899 } 1900 if(pkg == "base") has_namespace <- TRUE 1901 if(file.exists(file.path(dir, "NAMESPACE"))) { 1902 nm <- parseNamespaceFile(basename(dir), dirname(dir)) 1903 has_namespace <- length(nm$dynlibs) > 0L 1904 } 1905 code_dir <- file.path(dir, "R") 1906 if(!dir.exists(code_dir)) 1907 stop(gettextf("directory '%s' does not contain R code", 1908 dir), 1909 domain = NA) 1910 file <- tempfile() 1911 on.exit(unlink(file)) 1912 if(!file.create(file)) stop("unable to create ", file, domain = NA) 1913 if(!all(.file_append_ensuring_LFs(file, 1914 list_files_with_type(code_dir, 1915 "code")))) 1916 stop("unable to write code files", domain = NA) 1917 } 1918 else if(!missing(file)) { 1919 pkg <- enc <- NA 1920 } else 1921 stop("you must specify 'package', 'dir' or 'file'") 1922 1923 if(missing(package) && !file_test("-f", file)) 1924 stop(gettextf("file '%s' does not exist", file), 1925 domain = NA) 1926 1927 ## Should there really be a 'verbose' argument? 1928 ## It may be useful to extract all foreign function calls but then 1929 ## we would want the calls back ... 1930 ## What we currently do is the following: if 'verbose' is true, we 1931 ## show all foreign function calls in abbreviated form with the line 1932 ## ending in either 'OK' or 'MISSING', and we return the list of 1933 ## 'bad' FF calls (i.e., where the 'PACKAGE' argument is missing) 1934 ## *invisibly* (so that output is not duplicated). 1935 ## Otherwise, if not verbose, we return the list of bad FF calls. 1936 1937 bad_exprs <- empty_exprs <- wrong_pkg <- other_problem <- list() 1938 other_desc <- character() 1939 bad_pkg <- character() 1940 dup_false <- list() 1941 FF_funs <- FF_fun_names <- c(".C", ".Fortran", ".Call", ".External", 1942 ".Call.graphics", ".External.graphics") 1943 ## As pointed out by DTL, packages could use non-base FF calls for 1944 ## which missing 'PACKAGE' arguments are not necessarily a problem. 1945 if(!missing(package)) { 1946 is_FF_fun_from_base <- 1947 vapply(FF_funs, 1948 function(f) { 1949 e <- .find_owner_env(f, code_env) 1950 (identical(e, baseenv()) 1951 || identical(e, .BaseNamespaceEnv)) 1952 }, 1953 NA) 1954 FF_funs <- FF_funs[is_FF_fun_from_base] 1955 } 1956 ## Also, need to handle base::.Call() etc ... 1957 FF_funs <- c(FF_funs, sprintf("base::%s", FF_fun_names)) 1958 1959 check_registration <- function(e, fr) { 1960 sym <- e[[2L]] 1961 name <- deparse(sym, nlines = 1L) 1962 if (name == "...") 1963 return ("SYMBOL OK") # we cannot check this, e.g. RProtoBuf 1964 1965 if (is.character(sym)) { 1966 if (!have_registration) return ("SYMBOL OK") 1967 FF_fun <- as.character(e[[1L]]) 1968 sym <- reg[[FF_fun]][[sym]] 1969 if(is.null(sym)) return ("SYMBOL OK") 1970 } 1971 1972 if (!is_installed) { 1973 if (!is_installed_msg) { 1974 other_problem <<- c(other_problem, e) 1975 other_desc <<- c(other_desc, "foreign function registration not tested, as package was not installed") 1976 is_installed_msg <<- TRUE 1977 } 1978 return("OTHER") # registration checks need the package to be installed 1979 } 1980 if (is.symbol(sym)) { # it might be something like pkg::sym (that's a call) 1981 if (!exists(name, code_env, inherits = FALSE)) { 1982 if (allow_suppress && 1983 name %in% utils::suppressForeignCheck(, package)) 1984 return ("SYMBOL OK") # skip false positives 1985 if (have_registration) { 1986 if (name %in% fr) { 1987 other_problem <<- c(other_problem, e) 1988 other_desc <<- 1989 c(other_desc, 1990 sprintf("symbol %s in the local frame", 1991 sQuote(name))) 1992 } else { 1993 other_problem <<- c(other_problem, e) 1994 other_desc <<- 1995 c(other_desc, 1996 sprintf("symbol %s not in namespace", 1997 sQuote(name))) 1998 } 1999 } 2000 return("OTHER") 2001 } 2002 } else if (suppressCheck(sym)) 2003 return("SKIPPED") 2004 2005 sym <- tryCatch(eval(sym, code_env), error = function(e) e) 2006 if (inherits(sym, "error")) { 2007 if (have_registration || !allow_suppress) { 2008 other_problem <<- c(other_problem, e) 2009 other_desc <<- 2010 c(other_desc, sprintf("Evaluating %s during check gives error\n%s", 2011 sQuote(name), sQuote(sym$message))) 2012 } 2013 return("OTHER") 2014 } 2015 2016 FF_fun <- as.character(e[[1L]]) 2017 ## lmom's sym evaluate to character, so try to look up. 2018 ## FIXME: maybe check this is not PACKAGE = "another package" 2019 if (is.character(sym)) { 2020 if (!have_registration) return ("SYMBOL OK") 2021 sym <- reg[[FF_fun]][[sym]] 2022 if(is.null(sym)) return ("SYMBOL OK") 2023 } 2024 2025 ## These are allowed and used by SU's packages so skip for now 2026 if (inherits(sym, "RegisteredNativeSymbol") 2027 || inherits(sym, "NativeSymbol")) 2028 return ("SYMBOL OK") 2029 2030 if (!inherits(sym, "NativeSymbolInfo")) { 2031 other_problem <<- c(other_problem, e) 2032 ## other_desc <<- c(other_desc, sprintf("\"%s\" is not of class \"%s\"", name, "NativeSymbolInfo")) 2033 other_desc <<- c(other_desc, sprintf("%s is of class \"%s\"", 2034 sQuote(name), class(sym))) 2035 return("OTHER") 2036 } 2037 ## This might be symbol from another (base?) package. 2038 ## Allow for Rcpp modules 2039 parg <- unclass(sym$dll)$name 2040 if(length(parg) == 1L && parg %notin% c("Rcpp", pkgDLL)) { 2041 wrong_pkg <<- c(wrong_pkg, e) 2042 bad_pkg <<- c(bad_pkg, parg) 2043 } 2044 numparms <- sym$numParameters 2045 if (length(numparms) && numparms >= 0) { 2046 ## We have to be careful if ... is in the call. 2047 if (any(as.character(e) == "...")) { 2048 other_problem <<- c(other_problem, e) 2049 other_desc <<- 2050 c(other_desc, 2051 sprintf("call includes ..., expected %d %s", 2052 numparms, 2053 if(numparms > 1L) "parameters" else "parameter")) 2054 } else { 2055 callparms <- length(e) - 2L 2056 if ("PACKAGE" %in% names(e)) callparms <- callparms - 1L 2057 if (FF_fun %in% c(".C", ".Fortran")) 2058 callparms <- callparms - length(intersect(names(e), c("NAOK", "DUP", "ENCODING"))) 2059 if (!is.null(numparms) && numparms >= 0L && numparms != callparms) { 2060 other_problem <<- c(other_problem, e) 2061 other_desc <<- 2062 c(other_desc, 2063 sprintf("call to %s with %d %s, expected %d", 2064 sQuote(name), callparms, 2065 if(callparms > 1L) "parameters" else "parameter", 2066 numparms)) 2067 return("OTHER") 2068 } 2069 } 2070 } 2071 if (inherits(sym, "CallRoutine") && 2072 (FF_fun %notin% c(".Call", ".Call.graphics"))) { 2073 other_problem <<- c(other_problem, e) 2074 other_desc <<- c(other_desc, sprintf("%s registered as %s, but called with %s", sQuote(name), ".Call", FF_fun)) 2075 return("OTHER") 2076 } 2077 if (inherits(sym, "ExternalRoutine") && !(FF_fun %in% c(".External", ".External.graphics"))) { 2078 other_problem <<- c(other_problem, e) 2079 other_desc <<- c(other_desc, sprintf("%s registered as %s, but called with %s", sQuote(name), ".External", FF_fun)) 2080 return("OTHER") 2081 } 2082 2083 "SYMBOL OK" 2084 } 2085 2086 find_bad_exprs <- function(e) { 2087 if(is.call(e) || is.expression(e)) { 2088 ## <NOTE> 2089 ## This picks up all calls, e.g. a$b, and they may convert 2090 ## to a vector. The function is the first element in all 2091 ## the calls we are interested in. 2092 ## BDR 2002-11-28 2093 ## </NOTE> 2094 if(deparse(e[[1L]])[1L] %in% FF_funs) { 2095 if(registration) check_registration(e, fr) 2096 dup <- e[["DUP"]] 2097 if(!is.null(dup) && !isTRUE(dup)) 2098 dup_false <<- c(dup_false, e) 2099 this <- "" 2100 this <- parg <- e[["PACKAGE"]] 2101 if (!is.na(pkg) && is.character(parg) && 2102 nzchar(parg) && parg != pkgDLL) { 2103 wrong_pkg <<- c(wrong_pkg, e) 2104 bad_pkg <<- c(bad_pkg, this) 2105 } 2106 parg <- if(!is.null(parg) && (nzchar(parg))) "OK" 2107 else if(identical(parg, "")) { 2108 empty_exprs <<- c(empty_exprs, e) 2109 "EMPTY" 2110 } else if(!is.character(sym <- e[[2L]])) { 2111 if (!registration) { 2112 sym <- tryCatch(eval(sym, code_env), 2113 error = function(e) e) 2114 if (inherits(sym, "NativeSymbolInfo")) { 2115 ## This might be symbol from another package. 2116 ## Allow for Rcpp modules 2117 parg <- unclass(sym$dll)$name 2118 if(length(parg) == 1L && 2119 parg %notin% c("Rcpp", pkgDLL)) { 2120 wrong_pkg <<- c(wrong_pkg, e) 2121 bad_pkg <<- c(bad_pkg, parg) 2122 } 2123 } 2124 } 2125 "Called with symbol" 2126 } else if(!has_namespace) { 2127 bad_exprs <<- c(bad_exprs, e) 2128 "MISSING" 2129 } else "MISSING but in a function in a namespace" 2130 if(verbose) 2131 if(is.null(this)) 2132 cat(deparse(e[[1L]]), "(", deparse(e[[2L]]), 2133 ", ... ): ", parg, "\n", sep = "") 2134 else 2135 cat(deparse(e[[1L]]), "(", deparse(e[[2L]]), 2136 ", ..., PACKAGE = \"", this, "\"): ", 2137 parg, "\n", sep = "") 2138 } else if (deparse(e[[1L]])[1L] %in% "<-") { 2139 fr <<- c(fr, as.character(e[[2L]])) 2140 } 2141 for(i in seq_along(e)) Recall(e[[i]]) 2142 } 2143 } 2144 2145 if(!missing(package)) { 2146 checkFFmy <- function(f) 2147 if(typeof(f) == "closure") { 2148 env <- environment(f) 2149 if(isNamespace(env)) { 2150 nm <- getNamespaceName(env) 2151 if (nm == package) body(f) else NULL 2152 } else body(f) 2153 } # else NULL 2154 exprs <- lapply(ls(envir = code_env, all.names = TRUE), 2155 function(f) checkFFmy(get(f, envir = code_env))) # get is expensive 2156 if(.isMethodsDispatchOn()) { 2157 ## Also check the code in S4 methods. 2158 ## This may find things twice if a setMethod() with a bad FF 2159 ## call is from inside a function (e.g., InitMethods()). 2160 for(f in .get_S4_generics(code_env)) { 2161 mlist <- .get_S4_methods_list(f, code_env) 2162 exprs <- c(exprs, lapply(mlist, body)) 2163 } 2164 refs <- .get_ref_classes(code_env) 2165 if(length(refs)) { 2166 exprs2 <- lapply(unlist(refs, FALSE), checkFFmy) 2167 exprs <- c(exprs, exprs2) 2168 } 2169 } 2170 } else { 2171 if(!is.na(enc) && 2172 (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { 2173 ## FIXME: what if conversion fails on e.g. UTF-8 comments 2174 con <- file(file, encoding=enc) 2175 on.exit(close(con)) 2176 } else con <- file 2177 exprs <- 2178 tryCatch(parse(file = con, n = -1L), 2179 error = function(e) 2180 stop(gettextf("parse error in file '%s':\n%s", 2181 file, 2182 .massage_file_parse_error_message(conditionMessage(e))), 2183 domain = NA, call. = FALSE)) 2184 } 2185 for(i in seq_along(exprs)) { 2186 fr <- character() 2187 find_bad_exprs(exprs[[i]]) 2188 } 2189 attr(bad_exprs, "wrong_pkg") <- wrong_pkg 2190 attr(bad_exprs, "bad_pkg") <- bad_pkg 2191 attr(bad_exprs, "empty") <- empty_exprs 2192 attr(bad_exprs, "other_problem") <- other_problem 2193 attr(bad_exprs, "other_desc") <- other_desc 2194 if(check_DUP) attr(bad_exprs, "dup_false") <- dup_false 2195 if (length(bad_pkg)) { # check against dependencies. 2196 bases <- .get_standard_package_names()$base 2197 bad <- bad_pkg %w/o% bases 2198 if (length(bad)) { 2199 depends <- .get_requires_from_package_db(db, "Depends") 2200 imports <- .get_requires_from_package_db(db, "Imports") 2201 suggests <- .get_requires_from_package_db(db, "Suggests") 2202 enhances <- .get_requires_from_package_db(db, "Enhances") 2203 bad <- bad %w/o% c(depends, imports, suggests, enhances) 2204 attr(bad_exprs, "undeclared") <- bad 2205 } 2206 } 2207 class(bad_exprs) <- "checkFF" 2208 if(verbose) 2209 invisible(bad_exprs) 2210 else 2211 bad_exprs 2212} 2213 2214format.checkFF <- 2215function(x, ...) 2216{ 2217 xx <- attr(x, "empty") 2218 y <- attr(x, "wrong_pkg") 2219 z <- attr(x, "bad_pkg") 2220 zz <- attr(x, "undeclared") 2221 other_problem <- attr(x, "other_problem") 2222 2223 res <- character() 2224 if (length(x)) { 2225 .fmt <- function(x) 2226 paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)") 2227 msg <- ngettext(length(x), 2228 "Foreign function call without 'PACKAGE' argument:", 2229 "Foreign function calls without 'PACKAGE' argument:", 2230 domain = NA) 2231 res <- c(msg, unlist(lapply(x, .fmt))) 2232 } 2233 if (length(xx)) { 2234 .fmt <- function(x) 2235 paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)") 2236 msg <- ngettext(length(x), 2237 "Foreign function call with empty 'PACKAGE' argument:", 2238 "Foreign function calls with empty 'PACKAGE' argument:", 2239 domain = NA) 2240 res <- c(res, msg, unlist(lapply(xx, .fmt))) 2241 } 2242 2243 if (length(y)) { 2244 bases <- .get_standard_package_names()$base 2245 .fmt2 <- function(x, z) { 2246 if("PACKAGE" %in% names(x)) 2247 paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), 2248 ", ..., PACKAGE = \"", z, "\")") 2249 else 2250 paste0(" ", deparse(x[[1L]]), "(", deparse(x[[2L]]), ", ...)") 2251 } 2252 base <- z %in% bases 2253 if(any(base)) { 2254 xx <- unlist(lapply(seq_along(y)[base], 2255 function(i) .fmt2(y[[i]], z[i]))) 2256 xx <- unique(xx) 2257 msg <- ngettext(length(xx), 2258 "Foreign function call to a base package:", 2259 "Foreign function calls to a base package:", 2260 domain = NA) 2261 res <- c(res, msg, sort(xx)) 2262 } 2263 if(any(!base)) { 2264 xx <- unlist(lapply(seq_along(y)[!base], 2265 function(i) .fmt2(y[[i]], z[i]))) 2266 xx <- unique(xx) 2267 msg <- ngettext(length(xx), 2268 "Foreign function call to a different package:", 2269 "Foreign function calls to a different package:", 2270 domain = NA) 2271 res <- c(res, msg, sort(xx)) 2272 } 2273 } 2274 if (length(zz)) { 2275 zz <- unique(zz) 2276 msg <- ngettext(length(zz), 2277 "Undeclared package in foreign function calls:", 2278 "Undeclared packages in foreign function calls:", 2279 domain = NA) 2280 res <- c(res, msg, paste(" ", paste(sQuote(sort(zz)), collapse = ", "))) 2281 } 2282 if (length(other_problem)) { 2283 msg <- ngettext(length(other_problem), 2284 "Registration problem:", 2285 "Registration problems:", 2286 domain = NA) 2287 res <- c(res, msg) 2288 other_desc <- attr(x, "other_desc") 2289 for (i in seq_along(other_problem)) { 2290 res <- c(res, paste0(" ", other_desc[i], ":"), 2291 paste0(" ", deparse(other_problem[[i]]))) 2292 } 2293 } 2294 z3 <- attr(x, "dup_false") 2295 if (length(z3)) { 2296 msg <- ngettext(length(z3), 2297 "Call with DUP:", 2298 "Calls with DUP:", 2299 domain = NA) 2300 res <- c(res, msg) 2301 for (i in seq_along(z3)) { 2302 res <- c(res, paste0(" ", deparse(z3[[i]]))) 2303 } 2304 } 2305 res 2306} 2307 2308### * checkS3methods 2309 2310checkS3methods <- 2311function(package, dir, lib.loc = NULL) 2312{ 2313 has_namespace <- FALSE 2314 ## If an installed package has a namespace, we need to record the S3 2315 ## methods which are registered but not exported (so that we can 2316 ## get() them from the right place). 2317 S3_reg <- character() 2318 2319 ## Argument handling. 2320 if(!missing(package)) { 2321 if(length(package) != 1L) 2322 stop("argument 'package' must be of length 1") 2323 dir <- find.package(package, lib.loc) 2324 ## Using package installed in @code{dir} ... 2325 code_dir <- file.path(dir, "R") 2326 if(!dir.exists(code_dir)) 2327 stop(gettextf("directory '%s' does not contain R code", 2328 dir), 2329 domain = NA) 2330 is_base <- basename(dir) == "base" 2331 2332 ## Load package into code_env. 2333 if(!is_base) 2334 .load_package_quietly(package, lib.loc) 2335 code_env <- .package_env(package) 2336 2337 objects_in_code <- sort(names(code_env)) 2338 2339 ## Does the package have a namespace? 2340 if(packageHasNamespace(package, dirname(dir))) { 2341 has_namespace <- TRUE 2342 ## Determine names of declared S3 methods and associated S3 2343 ## generics. 2344 ns_S3_methods_db <- getNamespaceInfo(package, "S3methods") 2345 ns_S3_generics <- as.character(ns_S3_methods_db[, 1L]) 2346 ## We really need the GENERIC.CLASS method names used in the 2347 ## registry: 2348 ns_S3_methods <- 2349 paste(ns_S3_generics, 2350 as.character(ns_S3_methods_db[, 2L]), 2351 sep = ".") 2352 ## Determine unexported but declared S3 methods. 2353 S3_reg <- setdiff(ns_S3_methods, objects_in_code) 2354 } 2355 } 2356 else { 2357 if(missing(dir)) 2358 stop("you must specify 'package' or 'dir'") 2359 ## Using sources from directory @code{dir} ... 2360 if(!dir.exists(dir)) 2361 stop(gettextf("directory '%s' does not exist", dir), 2362 domain = NA) 2363 else 2364 dir <- file_path_as_absolute(dir) 2365 code_dir <- file.path(dir, "R") 2366 if(!dir.exists(code_dir)) 2367 stop(gettextf("directory '%s' does not contain R code", 2368 dir), 2369 domain = NA) 2370 is_base <- basename(dir) == "base" 2371 2372 code_env <- new.env(hash = TRUE) 2373 dfile <- file.path(dir, "DESCRIPTION") 2374 meta <- if(file_test("-f", dfile)) 2375 .read_description(dfile) 2376 else 2377 character() 2378 .source_assignments_in_code_dir(code_dir, code_env, meta) 2379 sys_data_file <- file.path(code_dir, "sysdata.rda") 2380 if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) 2381 2382 objects_in_code <- sort(names(code_env)) 2383 2384 ## Does the package have a NAMESPACE file? 2385 if(file.exists(file.path(dir, "NAMESPACE"))) { 2386 has_namespace <- TRUE 2387 nsInfo <- parseNamespaceFile(basename(dir), dirname(dir)) 2388 ## Determine exported objects. 2389 OK <- intersect(objects_in_code, nsInfo$exports) 2390 for(p in nsInfo$exportPatterns) 2391 OK <- c(OK, grep(p, objects_in_code, value = TRUE)) 2392 objects_in_code <- unique(OK) 2393 ## Determine names of declared S3 methods and associated S3 2394 ## generics. 2395 ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo) 2396 ns_S3_generics <- ns_S3_methods_db[, 1L] 2397 ns_S3_methods <- ns_S3_methods_db[, 3L] 2398 } 2399 2400 } 2401 2402 ## Find the function objects in the given package. 2403 functions_in_code <- 2404 Filter(function(f) is.function(code_env[[f]]), 2405 objects_in_code) 2406 2407 ## This is the virtual group generics, not the members 2408 S3_group_generics <- .get_S3_group_generics() 2409 ## This includes the primitive group generics as from R 2.6.0 2410 S3_primitive_generics <- .get_S3_primitive_generics() 2411 2412 checkArgs <- function(g, m) { 2413 ## Do the arguments of method m (in code_env) 'extend' those of 2414 ## the generic g as seen from code_env? The method must have all 2415 ## arguments the generic has, with positional arguments of g in 2416 ## the same positions for m. 2417 ## Exception: '...' in the method swallows anything. 2418 if(identical(g, "round") && m == "round.POSIXt") return() # exception 2419 genfun <- get(g, envir = code_env) 2420 gArgs <- names(formals(genfun)) 2421 if(identical(g, "plot")) gArgs <- gArgs[-2L] # drop "y" 2422 ogArgs <- gArgs 2423 gm <- if(m %in% S3_reg) { 2424 ## See registerS3method() in ../../base/R/namespace.R. 2425 defenv <- 2426 if (g %in% S3_group_generics || g %in% S3_primitive_generics) 2427 .BaseNamespaceEnv 2428 else { 2429 if(.isMethodsDispatchOn() 2430 && methods::is(genfun, "genericFunction")) 2431 genfun <- methods::finalDefaultMethod(genfun@default) 2432 if (typeof(genfun) == "closure") environment(genfun) 2433 else .BaseNamespaceEnv 2434 } 2435 if(is.null(S3Table <- get0(".__S3MethodsTable__.", envir = defenv, 2436 inherits = FALSE))) { 2437 ## Happens e.g. if for some reason, we get "plot" as 2438 ## standardGeneric for "plot" defined from package 2439 ## "graphics" with its own environment which does not 2440 ## contain an S3 methods table ... 2441 return(NULL) 2442 } 2443 if(is.null(mm <- get0(m, envir = S3Table))) { 2444 warning(gettextf("declared S3 method '%s' not found", m), 2445 domain = NA, call. = FALSE) 2446 return(NULL) 2447 } else mm 2448 } else get(m, envir = code_env) 2449 mArgs <- omArgs <- names(formals(gm)) 2450 ## If m is a formula method, its first argument *may* be called 2451 ## formula. (Note that any argument name mismatch throws an 2452 ## error in current S-PLUS versions.) 2453 if(endsWith(m, ".formula")) { 2454 if(gArgs[1L] != "...") gArgs <- gArgs[-1L] 2455 if(mArgs[1L] != "...") mArgs <- mArgs[-1L] 2456 } 2457 dotsPos <- which(gArgs == "...") 2458 ipos <- if(length(dotsPos)) 2459 seq_len(dotsPos[1L] - 1L) 2460 else 2461 seq_along(gArgs) 2462 2463 ## careful, this could match multiply in incorrect funs. 2464 dotsPos <- which(mArgs == "...") 2465 if(length(dotsPos)) 2466 ipos <- ipos[seq_len(dotsPos[1L] - 1L)] 2467 posMatchOK <- identical(gArgs[ipos], mArgs[ipos]) 2468 argMatchOK <- all(gArgs %in% mArgs) || length(dotsPos) > 0L 2469 margMatchOK <- all(mArgs %in% c("...", gArgs)) || "..." %in% ogArgs 2470 if(posMatchOK && argMatchOK && margMatchOK) 2471 NULL 2472 else if (g %in% c("+", "-", "*", "/", "^", "%%", "%/%", "&", "|", 2473 "!", "==", "!=", "<", "<=", ">=", ">") 2474 && (length(ogArgs) == length(omArgs)) ) 2475 NULL 2476 else { 2477 l <- list(ogArgs, omArgs) 2478 names(l) <- c(g, m) 2479 list(l) 2480 } 2481 } ## end{ checkArgs() } 2482 2483 all_S3_generics <- 2484 unique(c(Filter(function(f) .is_S3_generic(f, envir = code_env), 2485 functions_in_code), 2486 .get_S3_generics_as_seen_from_package(dir, 2487 !missing(package), 2488 TRUE), 2489 ## This had 'FALSE' for a long time, in which case we 2490 ## miss the primitive generics regarded as language 2491 ## elements. 2492 S3_group_generics, S3_primitive_generics)) 2493 ## <FIXME> 2494 ## Not yet: 2495 code_env <- .make_S3_group_generic_env(parent = code_env) 2496 ## </FIXME> 2497 code_env <- .make_S3_primitive_generic_env(parent = code_env) 2498 2499 ## Now determine the 'bad' methods in the function objects of the 2500 ## package. 2501 bad_methods <- list() 2502 methods_stop_list <- nonS3methods(basename(dir)) 2503 ## some packages export S4 generics derived from other packages .... 2504 methods_stop_list <- 2505 c(methods_stop_list, 2506 "all.equal", "all.names", "all.vars", "fitted.values", "qr.Q", 2507 "qr.R", "qr.X", "qr.coef", "qr.fitted", "qr.qty", "qr.qy", 2508 "qr.resid", "qr.solve", "rep.int", "seq.int", "sort.int", 2509 "sort.list", "t.test") 2510 methods_not_registered_but_exported <- character() 2511 ## <FIXME> 2512 ## Seems we currently cannot get these, because we only look at 2513 ## *exported* functions in addition to the S3 registry. 2514 methods_not_registered_not_exported <- character() 2515 ## </FIXME> 2516 for(g in all_S3_generics) { 2517 if(!exists(g, envir = code_env)) next 2518 ## Find all methods in functions_in_code for S3 generic g. 2519 ## <FIXME> 2520 ## We should really determine the name g dispatches for, see 2521 ## a current version of methods() [2003-07-07]. (Care is 2522 ## needed for internal generics and group generics.) 2523 name <- paste0(g, ".") 2524 methods <- 2525 functions_in_code[startsWith(functions_in_code, name)] 2526 ## </FIXME> 2527 methods <- setdiff(methods, methods_stop_list) 2528 if(has_namespace) { 2529 ## Find registered methods for generic g. 2530 methods <- c(methods, ns_S3_methods[ns_S3_generics == g]) 2531 if(length(delta <- setdiff(methods, ns_S3_methods))) { 2532 methods_not_registered_but_exported <- 2533 c(methods_not_registered_but_exported, 2534 intersect(delta, objects_in_code)) 2535 methods_not_registered_not_exported <- 2536 c(methods_not_registered_not_exported, 2537 setdiff(delta, objects_in_code)) 2538 } 2539 } 2540 2541 if(any(g == langElts)) next 2542 2543 for(m in methods) 2544 ## Both all() and all.equal() are generic. 2545 bad_methods <- if(g == "all") { 2546 m1 <- m[!startsWith(m, "all.equal")] 2547 c(bad_methods, if(length(m1)) checkArgs(g, m1)) 2548 } else c(bad_methods, checkArgs(g, m)) 2549 } 2550 2551 if(length(methods_not_registered_but_exported)) 2552 attr(bad_methods, "methods_not_registered_but_exported") <- 2553 methods_not_registered_but_exported 2554 if(length(methods_not_registered_not_exported)) 2555 attr(bad_methods, "methods_not_registered_not_exported") <- 2556 methods_not_registered_not_exported 2557 2558 class(bad_methods) <- "checkS3methods" 2559 bad_methods 2560} 2561 2562format.checkS3methods <- 2563function(x, ...) 2564{ 2565 format_args <- function(s) 2566 paste0("function(", paste(s, collapse = ", "), ")") 2567 2568 .fmt <- function(entry) { 2569 c(paste0(names(entry)[1L], ":"), 2570 strwrap(format_args(entry[[1L]]), indent = 2L, exdent = 11L), 2571 paste0(names(entry)[2L], ":"), 2572 strwrap(format_args(entry[[2L]]), indent = 2L, exdent = 11L), 2573 "") 2574 } 2575 2576 report_S3_methods_not_registered <- 2577 config_val_to_logical(Sys.getenv("_R_CHECK_S3_METHODS_NOT_REGISTERED_", 2578 "TRUE")) 2579 2580 c(as.character(unlist(lapply(x, .fmt))), 2581 if(report_S3_methods_not_registered && 2582 length(methods <- attr(x, "methods_not_registered_but_exported"))) { 2583 c("Found the following apparent S3 methods exported but not registered:", 2584 strwrap(paste(sort(methods), collapse = " "), 2585 exdent = 2L, indent = 2L)) 2586 } 2587 ) 2588} 2589 2590### * checkReplaceFuns 2591 2592checkReplaceFuns <- 2593function(package, dir, lib.loc = NULL) 2594{ 2595 has_namespace <- FALSE 2596 2597 ## Argument handling. 2598 if(!missing(package)) { 2599 if(length(package) != 1L) 2600 stop("argument 'package' must be of length 1") 2601 dir <- find.package(package, lib.loc) 2602 ## Using package installed in @code{dir} ... 2603 code_dir <- file.path(dir, "R") 2604 if(!dir.exists(code_dir)) 2605 stop(gettextf("directory '%s' does not contain R code", 2606 dir), 2607 domain = NA) 2608 is_base <- basename(dir) == "base" 2609 2610 ## Load package into code_env. 2611 if(!is_base) 2612 .load_package_quietly(package, lib.loc) 2613 ## In case the package has a namespace, we really want to check 2614 ## all replacement functions in the package. (If not, we need 2615 ## to change the code for the non-installed case to only look at 2616 ## exported (replacement) functions.) 2617 if(packageHasNamespace(package, dirname(dir))) { 2618 has_namespace <- TRUE 2619 code_env <- asNamespace(package) 2620 ns_S3_methods_db <- .getNamespaceInfo(code_env, "S3methods") 2621 } 2622 else 2623 code_env <- .package_env(package) 2624 } else { # missing(package) 2625 if(missing(dir)) 2626 stop("you must specify 'package' or 'dir'") 2627 ## Using sources from directory @code{dir} ... 2628 if(!dir.exists(dir)) 2629 stop(gettextf("directory '%s' does not exist", dir), 2630 domain = NA) 2631 else 2632 dir <- file_path_as_absolute(dir) 2633 code_dir <- file.path(dir, "R") 2634 if(!dir.exists(code_dir)) 2635 stop(gettextf("directory '%s' does not contain R code", 2636 dir), 2637 domain = NA) 2638 is_base <- basename(dir) == "base" 2639 2640 code_env <- new.env(hash = TRUE) 2641 dfile <- file.path(dir, "DESCRIPTION") 2642 meta <- if(file_test("-f", dfile)) 2643 .read_description(dfile) 2644 else 2645 character() 2646 .source_assignments_in_code_dir(code_dir, code_env, meta) 2647 sys_data_file <- file.path(code_dir, "sysdata.rda") 2648 if(file_test("-f", sys_data_file)) load(sys_data_file, code_env) 2649 2650 ## Does the package have a NAMESPACE file? Note that when 2651 ## working on the sources we (currently?) cannot deal with the 2652 ## (experimental) alternative way of specifying the namespace. 2653 if(file.exists(file.path(dir, "NAMESPACE"))) { 2654 has_namespace <- TRUE 2655 nsInfo <- parseNamespaceFile(basename(dir), dirname(dir)) 2656 ns_S3_methods_db <- .get_namespace_S3_methods_db(nsInfo) 2657 } 2658 } 2659 2660 objects_in_code <- sort(names(code_env)) 2661 replace_funs <- character() 2662 2663 if(has_namespace) { 2664 ns_S3_generics <- as.character(ns_S3_methods_db[, 1L]) 2665 ns_S3_methods <- ns_S3_methods_db[, 3L] 2666 if(!is.character(ns_S3_methods)) { 2667 ## As of 2018-07, direct calls to registerS3method() 2668 ## could have registered a function object (not name). 2669 ind <- vapply(ns_S3_methods, is.character, NA) 2670 ns_S3_methods[!ind] <- "" 2671 ns_S3_methods <- as.character(ns_S3_methods) 2672 } 2673 ## S3 replacement methods from namespace registration? 2674 replace_funs <- ns_S3_methods[endsWith(ns_S3_generics, "<-")] 2675 ## Now remove the functions registered as S3 methods. 2676 objects_in_code <- setdiff(objects_in_code, ns_S3_methods) 2677 } 2678 2679 replace_funs <- 2680 c(replace_funs, grep("<-", objects_in_code, value = TRUE)) 2681 ## Drop %xxx% binops. 2682 ## Spotted by Hugh Parsonage <hugh.parsonage@gmail.com>. 2683 replace_funs <- 2684 replace_funs[!(startsWith(replace_funs, "%") & 2685 endsWith(replace_funs, "%"))] 2686 2687 .check_last_formal_arg <- function(f) { 2688 arg_names <- names(formals(f)) 2689 if(!length(arg_names)) 2690 TRUE # most likely a .Primitive() 2691 else 2692 identical(arg_names[length(arg_names)], "value") 2693 } 2694 2695 ## Find the replacement functions (which have formal arguments) with 2696 ## last arg not named 'value'. 2697 bad_replace_funs <- if(length(replace_funs)) { 2698 Filter(function(f) { 2699 ## Always get the functions from code_env ... 2700 ## Should maybe get S3 methods from the registry ... 2701 f <- get(f, envir = code_env) # get is expensive 2702 is.function(f) && ! .check_last_formal_arg(f) 2703 }, 2704 replace_funs) 2705 } else character() 2706 2707 if(.isMethodsDispatchOn()) { 2708 S4_generics <- .get_S4_generics(code_env) 2709 ## Assume that the ones with names ending in '<-' are always 2710 ## replacement functions. 2711 S4_generics <- S4_generics[endsWith(names(S4_generics), "<-")] 2712 bad_S4_replace_methods <- 2713 lapply(S4_generics, 2714 function(f) { 2715 mlist <- .get_S4_methods_list(f, code_env) 2716 ind <- !vapply(mlist, .check_last_formal_arg, NA) 2717 if(!any(ind)) 2718 character() 2719 else { 2720 sigs <- .make_siglist(mlist[ind]) 2721 sprintf("\\S4method{%s}{%s}", f, sigs) 2722 } 2723 }) 2724 bad_replace_funs <- 2725 c(bad_replace_funs, 2726 unlist(bad_S4_replace_methods, use.names = FALSE)) 2727 } 2728 2729 class(bad_replace_funs) <- "checkReplaceFuns" 2730 bad_replace_funs 2731} 2732 2733format.checkReplaceFuns <- 2734function(x, ...) 2735{ 2736 if(length(x)) 2737 .pretty_format(unclass(x)) 2738 else 2739 character() 2740} 2741 2742### * checkTnF 2743 2744checkTnF <- 2745function(package, dir, file, lib.loc = NULL) 2746{ 2747 code_files <- docs_files <- character() 2748 2749 ## Argument handling. 2750 if(!missing(package)) { 2751 if(length(package) != 1L) 2752 stop("argument 'package' must be of length 1") 2753 ## Using package installed in @code{dir} ... 2754 dir <- find.package(package, lib.loc) 2755 if(file.exists(file.path(dir, "R", "all.rda"))) { 2756 warning("cannot check R code installed as image") 2757 } 2758 code_file <- file.path(dir, "R", package) 2759 if(file.exists(code_file)) # could be data-only 2760 code_files <- code_file 2761 example_dir <- file.path(dir, "R-ex") 2762 if(dir.exists(example_dir)) { 2763 code_files <- c(code_files, 2764 list_files_with_exts(example_dir, "R")) 2765 } 2766 } 2767 else if(!missing(dir)) { 2768 ## Using sources from directory @code{dir} ... 2769 if(!dir.exists(dir)) 2770 stop(gettextf("directory '%s' does not exist", dir), 2771 domain = NA) 2772 else 2773 dir <- file_path_as_absolute(dir) 2774 code_dir <- file.path(dir, "R") 2775 if(dir.exists(code_dir)) # could be data-only 2776 code_files <- list_files_with_type(code_dir, "code") 2777 docs_dir <- file.path(dir, "man") 2778 if(dir.exists(docs_dir)) 2779 docs_files <- list_files_with_type(docs_dir, "docs") 2780 } 2781 else if(!missing(file)) { 2782 if(!file_test("-f", file)) 2783 stop(gettextf("file '%s' does not exist", file), 2784 domain = NA) 2785 else 2786 code_files <- file 2787 } 2788 else 2789 stop("you must specify 'package', 'dir' or 'file'") 2790 2791 find_TnF_in_code <- function(file, txt) { 2792 ## If 'txt' is given, it contains the extracted examples from 2793 ## the R documentation file 'file'. Otherwise, 'file' gives a 2794 ## file with (just) R code. 2795 matches <- list() 2796 TnF <- c("T", "F") 2797 find_bad_exprs <- function(e, p) { 2798 if(is.name(e) 2799 && (as.character(e) %in% TnF) 2800 && !is.null(p)) { 2801 ## Need the 'list()' to deal with T/F in function 2802 ## arglists which are pairlists ... 2803 matches <<- c(matches, list(p)) 2804 } 2805 else if(is.recursive(e)) { 2806 for(i in seq_along(e)) Recall(e[[i]], e) 2807 } 2808 } 2809 exprs <- if(missing(txt)) 2810 tryCatch(parse(file = file, n = -1L), 2811 error = function(e) 2812 stop(gettextf("parse error in file '%s':\n", 2813 file, 2814 .massage_file_parse_error_message(conditionMessage(e))), 2815 domain = NA, call. = FALSE)) 2816 else 2817 tryCatch(str2expression(txt), 2818 error = function(e) 2819 stop(gettextf("parse error in examples from file '%s':\n", 2820 file, conditionMessage(e)), 2821 domain = NA, call. = FALSE)) 2822 for(i in seq_along(exprs)) 2823 find_bad_exprs(exprs[[i]], NULL) 2824 matches 2825 } 2826 2827 bad_exprs <- list() 2828 for(file in code_files) { 2829 exprs <- find_TnF_in_code(file) 2830 if(length(exprs)) { 2831 exprs <- list(exprs) 2832 names(exprs) <- file 2833 bad_exprs <- c(bad_exprs, exprs) 2834 } 2835 } 2836 for(file in docs_files) { 2837 Rd <- prepare_Rd(file, defines = .Platform$OS.type) 2838 txt <- .Rd_get_example_code(Rd) 2839 exprs <- find_TnF_in_code(file, txt) 2840 if(length(exprs)) { 2841 exprs <- list(exprs) 2842 names(exprs) <- file 2843 bad_exprs <- c(bad_exprs, exprs) 2844 } 2845 } 2846 class(bad_exprs) <- "checkTnF" 2847 bad_exprs 2848} 2849 2850format.checkTnF <- 2851function(x, ...) 2852{ 2853 .fmt <- function(fname) { 2854 xfname <- x[[fname]] 2855 c(gettextf("File '%s':", fname), 2856 unlist(lapply(seq_along(xfname), 2857 function(i) { 2858 strwrap(gettextf("found T/F in %s", 2859 paste(deparse(xfname[[i]]), 2860 collapse = "")), 2861 exdent = 4L) 2862 })), 2863 "") 2864 } 2865 2866 as.character(unlist(lapply(names(x), .fmt))) 2867} 2868 2869### * .check_package_depends 2870 2871## changed in 2.3.0 to refer to a source dir. 2872 2873.check_package_depends <- 2874function(dir, force_suggests = TRUE, check_incoming = FALSE, 2875 ignore_vignettes = FALSE) 2876{ 2877 .check_dependency_cycles <- 2878 function(db, available = utils::available.packages(), 2879 dependencies = c("Depends", "Imports", "LinkingTo")) 2880 { 2881 ## given a package, find its recursive dependencies. 2882 ## We want the dependencies of the current package, 2883 ## not of a version on the repository. 2884## pkg <- db[["Package"]] 2885 this <- db[dependencies]; names(this) <- dependencies 2886 ## FIXME: .extract_dependency_package_names 2887 known <- utils:::.clean_up_dependencies(this) 2888 info <- available[, dependencies, drop = FALSE] 2889 rn <- rownames(info) 2890 deps <- function(p) { 2891 if(p %notin% rn) return(character()) 2892 ## FIXME: .extract_dependency_package_names 2893 utils:::.clean_up_dependencies(info[p, ]) 2894 } 2895 extra <- known 2896 repeat { 2897 extra <- unlist(lapply(extra, deps)) 2898 extra <- setdiff(extra, known) 2899 if(!length(extra)) break 2900 known <- c(known, extra) 2901 } 2902 known 2903 } 2904 2905 if(length(dir) != 1L) 2906 stop("The package 'dir' argument must be of length 1") 2907 2908 ## We definitely need a valid DESCRIPTION file. 2909 db <- .read_description(file.path(dir, "DESCRIPTION")) 2910 2911 dir_name <- basename(dir) 2912 package_name <- db["Package"] 2913 if(!identical(package_name, dir_name) && 2914 (!is.character(package_name) || !nzchar(package_name))) { 2915 message(sprintf( 2916 "package name '%s' seems invalid; using directory name '%s' instead", 2917 package_name, dir_name)) 2918 package_name <- dir_name 2919 } 2920 2921 bad_depends <- list() 2922 ## and we cannot have cycles 2923 ## this check needs a package db from repository(s), so 2924 repos <- getOption("repos") 2925 if(any(grepl("@CRAN@", repos))) 2926 repos <- .get_standard_repository_URLs() 2927 if(!any(grepl("@CRAN@", repos))) { 2928 ## Not getting here should no longer be possble ... 2929 available <- utils::available.packages(repos = repos) 2930 ad <- .check_dependency_cycles(db, available) 2931 pkgname <- db[["Package"]] 2932 if(pkgname %in% ad) 2933 bad_depends$all_depends <- setdiff(ad, pkgname) 2934 } else if (check_incoming) 2935 bad_depends$skipped <- 2936 " No repository set, so cyclic dependency check skipped" 2937 2938 ldepends <- .get_requires_with_version_from_package_db(db, "Depends") 2939 limports <- .get_requires_with_version_from_package_db(db, "Imports") 2940 llinks <- .get_requires_with_version_from_package_db(db, "LinkingTo") 2941 lsuggests <- .get_requires_with_version_from_package_db(db, "Suggests") 2942 ## NB: no one checks version for 'Enhances'. 2943 lenhances <- .get_requires_with_version_from_package_db(db, "Enhances") 2944 ## VignetteBuilder packages are needed to ascertain what is a vignette. 2945 VB <- .get_requires_from_package_db(db, "VignetteBuilder") 2946 2947 ## FIXME: use vapply to get a character vector. 2948 depends <- sapply(ldepends, `[[`, 1L) 2949 imports <- sapply(limports, `[[`, 1L) 2950 links <- sapply(llinks, `[[`, 1L) 2951 suggests <- sapply(lsuggests, `[[`, 1L) 2952 2953 standard_package_names <- .get_standard_package_names() 2954 2955 ## Are all packages listed in Depends/Suggests/Imports/LinkingTo installed? 2956 lreqs <- c(ldepends, limports, llinks, 2957 if(force_suggests) lsuggests) 2958 lreqs2 <- c(if(!force_suggests) lsuggests, lenhances) 2959 if(length(c(lreqs, lreqs2))) { 2960 ## Do this directly for speed. 2961 installed <- character() 2962 installed_in <- character() 2963 for(lib in .libPaths()) { 2964 pkgs <- list.files(lib) 2965 pkgs <- pkgs[file.access(file.path(lib, pkgs, "DESCRIPTION"), 4) == 0] 2966 installed <- c(installed, pkgs) 2967 installed_in <- c(installed_in, rep.int(lib, length(pkgs))) 2968 } 2969 if (length(lreqs)) { 2970 reqs <- unique(sapply(lreqs, `[[`, 1L)) 2971 reqs <- setdiff(reqs, installed) 2972 m <- reqs %in% standard_package_names$stubs 2973 if(length(reqs[!m])) { 2974 bad <- reqs[!m] 2975 ## EDanalysis has a package in all of Depends, Imports, Suggests. 2976 bad1 <- bad[bad %in% c(depends, imports, links)] 2977 if(length(bad1)) 2978 bad_depends$required_but_not_installed <- bad1 2979 bad2 <- setdiff(bad, bad1) 2980 if(length(bad2)) 2981 bad_depends$suggested_but_not_installed <- bad2 2982 } 2983 if(length(reqs[m])) 2984 bad_depends$required_but_stub <- reqs[m] 2985 ## now check versions 2986 have_ver <- vapply(lreqs, function(x) length(x) == 3L, NA) 2987 lreqs3 <- lreqs[have_ver] 2988 if(length(lreqs3)) { 2989 bad <- character() 2990 for (r in lreqs3) { 2991 pkg <- r[[1L]] 2992 op <- r[[2L]] 2993 where <- which(installed == pkg) 2994 if(!length(where)) next 2995 ## want the first one 2996 desc <- readRDS(file.path(installed_in[where[1L]], pkg, 2997 "Meta", "package.rds")) 2998 current <- desc$DESCRIPTION["Version"] 2999 target <- as.package_version(r[[3L]]) 3000 if(!do.call(op, list(current, target))) 3001 bad <- c(bad, pkg) 3002 } 3003 if(length(bad)) 3004 bad_depends$required_but_obsolete <- bad 3005 } 3006 } 3007 if (length(lenhances) && 3008 !config_val_to_logical(Sys.getenv("_R_CHECK_PACKAGE_DEPENDS_IGNORE_MISSING_ENHANCES_", 3009 "FALSE"))) { 3010 m <- setdiff(sapply(lenhances, `[[`, 1L), installed) 3011 if(length(m)) 3012 bad_depends$enhances_but_not_installed <- m 3013 } 3014 if (!force_suggests && length(lsuggests)) { 3015 m <- setdiff(sapply(lsuggests, `[[`, 1L), installed) 3016 if(length(m)) 3017 bad_depends$suggests_but_not_installed <- m 3018 } 3019 if (!ignore_vignettes && length(VB)) { 3020 ## These need both to be declared and installed 3021 ## If people explicitly state 'utils' they ought really to 3022 ## declare it, but skip for now. 3023 bad <- VB %w/o% c(package_name, "utils", depends, imports, suggests) 3024 if(length(bad)) 3025 bad_depends$required_for_checking_but_not_declared <- bad 3026 bad2 <- VB %w/o% c(package_name, installed) 3027 bad2 <- setdiff(bad2, bad) 3028 if(length(bad2)) 3029 bad_depends$required_for_checking_but_not_installed <- bad2 3030 } 3031 } 3032 ## FIXME: is this still needed now we do dependency analysis? 3033 ## Are all vignette dependencies at least suggested or equal to 3034 ## the package name? 3035 3036 ## This is a check for old-location vignettes. 3037 ## If the package itself is the VignetteBuilder, 3038 ## we may not have installed it yet. 3039 defer <- package_name %in% db["VignetteBuilder"] 3040 vigns <- pkgVignettes(dir = dir, subdirs = file.path("inst", "doc"), 3041 check = !defer) 3042 3043 if(length(vigns$msg)) 3044 bad_depends$bad_engine <- vigns$msg 3045 if (!is.null(vigns) && length(vigns$docs) > 0L) { 3046 reqs <- unique(unlist(.build_vignette_index(vigns)$Depends)) 3047 ## For the time being, ignore base packages missing from the 3048 ## DESCRIPTION dependencies even if explicitly given as vignette 3049 ## dependencies. 3050 reqs <- setdiff(reqs, 3051 c(depends, imports, suggests, package_name, 3052 standard_package_names$base)) 3053 if(length(reqs)) 3054 bad_depends$missing_vignette_depends <- reqs 3055 } 3056 3057 ## Are all namespace dependencies listed as package dependencies? 3058 if(file_test("-f", file.path(dir, "NAMESPACE"))) { 3059 reqs <- .get_namespace_package_depends(dir) 3060 ## <FIXME> 3061 ## Not clear whether we want to require *all* namespace package 3062 ## dependencies listed in DESCRIPTION, or e.g. just the ones on 3063 ## non-base packages. Do the latter for time being ... 3064 ## Actually we need to know at least about S4-using packages, 3065 ## since we need to reinstall if those change. 3066 allowed_imports <- 3067 setdiff(standard_package_names$base, c("methods", "stats4")) 3068 reqs <- setdiff(reqs, c(imports, depends, allowed_imports)) 3069 if(length(reqs)) 3070 bad_depends$missing_namespace_depends <- reqs 3071 } 3072 3073 ## Check for excessive 'Depends' 3074 deps <- setdiff(depends, c("R", "base", "datasets", "grDevices", 3075 "graphics", "methods", "utils", "stats")) 3076 if(length(deps) > 5L) bad_depends$many_depends <- deps 3077 3078 ## and Imports 3079 lim <- as.integer(Sys.getenv("_R_CHECK_EXCESSIVE_IMPORTS_", "0")) 3080 imps <- setdiff(imports, standard_package_names$base) 3081 if(!is.na(lim) && lim > 0 && length(imps) > lim) 3082 bad_depends$many_imports <- imps 3083 3084 ## check header-only packages 3085 if (check_incoming) { 3086 hdOnly <- c("BH", "RcppArmadillo", "RcppEigen") 3087 hd <- setdiff(intersect(hdOnly, c(depends, imports)), 3088 .get_namespace_package_depends(dir, TRUE)) 3089 if(length(hd)) bad_depends$hdOnly <- hd 3090 } 3091 3092 ## Check RdMacros. 3093 RM <- setdiff(.get_requires_from_package_db(db, "RdMacros"), 3094 c(imports, depends)) 3095 if(length(RM)) bad_depends$missing_rdmacros_depends <- RM 3096 3097 ## (added in 4.0.0) Check for orphaned packages. 3098 if (config_val_to_logical(Sys.getenv("_R_CHECK_ORPHANED_", "FALSE"))) { 3099 ## empty fields are list(). 3100 strict <- setdiff(unique(c(as.character(depends), 3101 as.character(imports), 3102 as.character(links))), 3103 bad_depends$required_but_not_installed) 3104 3105 ## (4.1.0) This needs to be recursive, since a package 3106 ## strictly depends on everything required to load it. 3107 ## All of those should be installed, so we only look at those which are. 3108 ## We include LinkingTo as if a dependency links to an 3109 ## orphaned package, it becomes uninstallable if the linked-to 3110 ## package is, or if it is removed. 3111 dependencies <- .expand_dependency_type_spec("strong") 3112 av <- utils::installed.packages()[, dependencies, drop = FALSE] 3113 rn <- row.names(av) 3114 new <- strict0 <- strict 3115 ex <- "bit" # since an update is promised. 3116 repeat { 3117 new <- intersect(new, rn) # avoid NAs in the next line 3118 need <- unname(unlist(apply(av[new, , drop = FALSE], 1L, 3119 utils:::.clean_up_dependencies))) 3120 new <- setdiff(need, c(strict, ex)) 3121 if(!length(new)) break 3122 strict <- union(strict, new) 3123 } 3124 3125 ## First use dependencies which are installed: strict dependencies 3126 ## need to be for a full check. 3127 ## Suggests might not even exist, so we suppress warnings. 3128 mt <- utils::maintainer 3129 strict2 <- sapply(strict, function(x) suppressWarnings(mt(x))) 3130 miss1 <- is.na(strict2) 3131 weak <- setdiff(as.character(suggests), 3132 bad_depends$suggested_but_not_installed) 3133 weak2 <- sapply(weak, function(x) suppressWarnings(mt(x))) 3134 miss2 <- is.na(weak2) 3135 if (any(miss1) || any(miss2)) { 3136 ## This may not be local and needs a complete CRAN mirror 3137 db <- CRAN_package_db()[, c("Package", "Maintainer")] 3138 orphaned <- db[db$Maintainer == "ORPHANED" , 1L] 3139 s2 <- intersect(strict[miss1], orphaned) 3140 w2 <- intersect(weak[miss2], orphaned) 3141 } else s2 <- w2 <- character() 3142 strict <- c(strict[!miss1 & strict2 == "ORPHANED"], s2) 3143 if(length(strict)) { 3144 strict0 <- sort(intersect(strict, strict0)) 3145 strict1 <- sort(setdiff(strict, strict0)) 3146 if(length(strict0)) bad_depends$orphaned <- strict0 3147 if(length(strict1)) bad_depends$orphaned1 <- strict1 3148 } 3149 weak <- c(weak[!miss2 & weak2 == "ORPHANED"], w2) 3150 if(length(weak)) bad_depends$orphaned2 <- sort(weak) 3151 } 3152 3153 class(bad_depends) <- "check_package_depends" 3154 bad_depends 3155} 3156 3157format.check_package_depends <- 3158function(x, ...) 3159{ 3160 c(character(), 3161 if(length(x$skipped)) c(x$skipped, ""), 3162 if(length(x$all_depends)) { 3163 c("There is circular dependency in the installation order:", 3164 .pretty_format2(" One or more packages in", x$all_depends), 3165 " depend on this package (for the versions on the repositories).", 3166 "") 3167 }, 3168 if(length(bad <- x$required_but_not_installed) > 1L) { 3169 c(.pretty_format2("Packages required but not available:", bad), "") 3170 } else if(length(bad)) { 3171 c(sprintf("Package required but not available: %s", sQuote(bad)), "") 3172 }, 3173 if(length(bad <- x$suggested_but_not_installed) > 1L) { 3174 c(.pretty_format2("Packages suggested but not available:", bad), "") 3175 } else if(length(bad)) { 3176 c(sprintf("Package suggested but not available: %s", sQuote(bad)), "") 3177 }, 3178 if(length(bad <- x$required_but_obsolete) > 1L) { 3179 c(.pretty_format2("Packages required and available but unsuitable versions:", 3180 bad), 3181 "") 3182 } else if(length(bad)) { 3183 c(sprintf("Package required and available but unsuitable version: %s", sQuote(bad)), 3184 "") 3185 }, 3186 if(length(bad <- x$required_but_stub) > 1L) { 3187 c("Former standard packages required but now defunct:", 3188 .pretty_format(bad), 3189 "") 3190 } else if(length(bad)) { 3191 c(sprintf("Former standard package required but now defunct: %s", 3192 sQuote(bad)), "") 3193 }, 3194 if(length(bad <- x$suggests_but_not_installed) > 1L) { 3195 c(.pretty_format2("Packages suggested but not available for checking:", 3196 bad), 3197 "") 3198 } else if(length(bad)) { 3199 c(sprintf("Package suggested but not available for checking: %s", 3200 sQuote(bad)), 3201 "") 3202 }, 3203 if(length(bad <- x$enhances_but_not_installed) > 1L) { 3204 c(.pretty_format2("Packages which this enhances but not available for checking:", 3205 bad), 3206 "") 3207 } else if(length(bad)) { 3208 c(sprintf("Package which this enhances but not available for checking: %s", sQuote(bad)), 3209 "") 3210 }, 3211 if(length(bad <- x$required_for_checking_but_not_declared) > 1L) { 3212 c(.pretty_format2("VignetteBuilder packages not declared:", bad), "") 3213 } else if(length(bad)) { 3214 c(sprintf("VignetteBuilder package not declared: %s", sQuote(bad)), "") 3215 }, 3216 if(length(bad <- x$required_for_checking_but_not_installed) > 1L) { 3217 c(.pretty_format2("VignetteBuilder packages required for checking but not installed:", bad), "") 3218 } else if(length(bad)) { 3219 c(sprintf("VignetteBuilder package required for checking but not installed: %s", sQuote(bad)), "") 3220 }, 3221 if(length(bad <- x$missing_vignette_depends)) { 3222 c(if(length(bad) > 1L) { 3223 c("Vignette dependencies not required:", .pretty_format(bad)) 3224 } else { 3225 sprintf("Vignette dependency not required: %s", sQuote(bad)) 3226 }, 3227 strwrap(gettextf("Vignette dependencies (%s entries) must be contained in the DESCRIPTION Depends/Suggests/Imports entries.", 3228 "\\VignetteDepends{}")), 3229 "") 3230 }, 3231 if(length(bad <- x$missing_rdmacros_depends)) { 3232 c(if(length(bad) > 1L) 3233 .pretty_format2("RdMacros packages not required:", bad) 3234 else 3235 sprintf("RdMacros package not required: %s", sQuote(bad)), 3236 strwrap("RdMacros packages must be contained in the DESCRIPTION Imports/Depends entries."), 3237 "") 3238 }, 3239 if(length(bad <- x$missing_namespace_depends)) { 3240 error_str <- "missing from DESCRIPTION Imports/Depends entries:" 3241 c(if(length(bad) > 1L) 3242 .pretty_format2(paste("Namespace dependencies", error_str), bad) 3243 else 3244 sprintf("Namespace dependency %s %s", error_str, sQuote(bad)), 3245 "") 3246 }, 3247 if(length(y <- x$many_depends)) { 3248 c(.pretty_format2("Depends: includes the non-default packages:", y), 3249 strwrap(paste("Adding so many packages to the search path", 3250 "is excessive", 3251 "and importing selectively is preferable." 3252 , collapse = ", ")), 3253 "") 3254 }, 3255 if(ly <- length(x$many_imports)) { 3256 c(sprintf("Imports includes %d non-default packages.", ly), 3257 strwrap(paste("Importing from so many packages", 3258 "makes the package vulnerable to any of them", 3259 "becoming unavailable. Move as many as possible to", 3260 "Suggests and use conditionally." 3261 , collapse = ", ")), 3262 "") 3263 }, 3264 if(length(y <- x$bad_engine)) { 3265 c(y, "") 3266 }, 3267 if(length(bad <- x$hdOnly)) { 3268 c(if(length(bad) > 1L) 3269 c("Packages in Depends/Imports which should probably only be in LinkingTo:", .pretty_format(bad)) 3270 else 3271 sprintf("Package in Depends/Imports which should probably only be in LinkingTo: %s", sQuote(bad)), 3272 "") 3273 }, 3274 if(length(bad <- x[["orphaned"]])) { 3275 c(if(length(bad) > 1L) 3276 c("Requires orphaned packages:", .pretty_format(bad)) 3277 else 3278 sprintf("Requires orphaned package: %s", sQuote(bad)), 3279 "") 3280 }, 3281 if(length(bad <- x[["orphaned1"]])) { 3282 c(if(length(bad) > 1L) 3283 c("Requires (indirectly) orphaned packages:", .pretty_format(bad)) 3284 else 3285 sprintf("Requires (indirectly) orphaned package: %s", sQuote(bad)), 3286 "") 3287 }, 3288 if(length(bad <- x[["orphaned2"]])) { 3289 c(if(length(bad) > 1L) 3290 c("Suggests orphaned packages:", .pretty_format(bad)) 3291 else 3292 sprintf("Suggests orphaned package: %s", sQuote(bad)), 3293 "") 3294 } 3295 ) 3296} 3297 3298### * .check_package_description 3299 3300.check_package_description <- 3301function(dfile, strict = FALSE, db = NULL) 3302{ 3303 if(is.null(db)) { 3304 dfile <- file_path_as_absolute(dfile) 3305 db <- .read_description(dfile) 3306 } 3307 3308 standard_package_names <- .get_standard_package_names() 3309 3310 valid_package_name_regexp <- 3311 .standard_regexps()$valid_package_name 3312 valid_package_version_regexp <- 3313 .standard_regexps()$valid_package_version 3314 3315 is_base_package <- 3316 !is.na(priority <- db["Priority"]) && priority == "base" 3317 3318 out <- list() # For the time being ... 3319 3320 ## Check encoding-related things first. 3321 3322 ## All field tags must be ASCII. 3323 if(any(ind <- !.is_ASCII(names(db)))) 3324 out$fields_with_non_ASCII_tags <- names(db)[ind] 3325 ## For all fields used by the R package management system, values 3326 ## must be ASCII as well (so that the RPM works in a C locale). 3327 ASCII_fields <- c(.get_standard_repository_db_fields(), 3328 "Encoding", "License") 3329 ASCII_fields <- intersect(ASCII_fields, names(db)) 3330 if(any(ind <- !.is_ASCII(db[ASCII_fields]))) 3331 out$fields_with_non_ASCII_values <- ASCII_fields[ind] 3332 3333 ## Determine encoding and re-encode if necessary and possible. 3334 if("Encoding" %in% names(db)) { 3335 encoding <- db["Encoding"] 3336 if(Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX")) 3337 db <- iconv(db, encoding, sub = "byte") 3338 } 3339 else if(!all(.is_ISO_8859(db))) { 3340 ## No valid Encoding metadata. 3341 ## Determine whether we can assume Latin1. 3342 out$missing_encoding <- TRUE 3343 } 3344 3345 if(anyNA(nchar(db, "c", TRUE))) { 3346 ## Ouch, invalid in the current locale. 3347 ## (Can only happen in a MBCS locale.) 3348 ## Try re-encoding from Latin1. 3349 db <- iconv(db, "latin1") 3350 } 3351 3352 ## Check Authors@R and expansion if needed. 3353 if(!is.na(aar <- db["Authors@R"]) && 3354 (is.na(db["Author"]) || is.na(db["Maintainer"]))) { 3355 res <- .check_package_description_authors_at_R_field(aar) 3356 if(is.na(db["Author"]) && 3357 !is.null(s <- attr(res, "Author"))) 3358 db["Author"] <- s 3359 if(is.na(db["Maintainer"]) && 3360 !is.null(s <- attr(res, "Maintainer"))) 3361 db["Maintainer"] <- s 3362 mostattributes(res) <- NULL # Keep names. 3363 out <- c(out, res) 3364 } 3365 3366 val <- package_name <- db["Package"] 3367 if(!is.na(val)) { 3368 tmp <- character() 3369 ## We allow 'R', which is not a valid package name. 3370 if(!grepl(sprintf("^(R|%s)$", valid_package_name_regexp), val)) 3371 tmp <- c(tmp, gettext("Malformed package name")) 3372 if(!is_base_package) { 3373 if(val %in% standard_package_names$base) 3374 tmp <- c(tmp, 3375 c("Invalid package name.", 3376 "This is the name of a base package.")) 3377 else if(val %in% standard_package_names$stubs) 3378 tmp <- c(tmp, 3379 c("Invalid package name.", 3380 "This name was used for a base package and is remapped by library().")) 3381 } 3382 if(length(tmp)) 3383 out$bad_package <- tmp 3384 } 3385 if(!is.na(val <- db["Version"]) 3386 && !is_base_package 3387 && !grepl(sprintf("^%s$", valid_package_version_regexp), val)) 3388 out$bad_version <- val 3389 if(!is.na(val <- db["Maintainer"]) 3390 && !grepl(.valid_maintainer_field_regexp, val)) 3391 out$bad_maintainer <- val 3392 3393 ## Optional entries in DESCRIPTION: 3394 ## Depends/Suggests/Imports/Enhances, Namespace, Priority. 3395 ## These must be correct if present. 3396 3397 val <- db[match(c("Depends", "Suggests", "Imports", "Enhances"), 3398 names(db), nomatch = 0L)] 3399 if(length(val)) { 3400 depends <- trimws(unlist(strsplit(val, ","))) 3401 bad_dep_entry <- bad_dep_op <- bad_dep_version <- character() 3402 dep_regexp <- 3403 paste0("^[[:space:]]*", 3404 paste0("(R|", valid_package_name_regexp, ")"), 3405 "([[:space:]]*\\(([^) ]+)[[:space:]]+([^) ]+)\\))?", 3406 "[[:space:]]*$") 3407 for(dep in depends) { 3408 if(!grepl(dep_regexp, dep)) { 3409 ## Entry does not match the regexp. 3410 bad_dep_entry <- c(bad_dep_entry, dep) 3411 next 3412 } 3413 if(nzchar(sub(dep_regexp, "\\2", dep))) { 3414 ## If not just a valid package name ... 3415 if(sub(dep_regexp, "\\3", dep) %notin% 3416 c("<=", ">=", "<", ">", "==", "!=")) 3417 bad_dep_op <- c(bad_dep_op, dep) 3418 else if(grepl("^[[:space:]]*R", dep)) { 3419 if(!grepl(sprintf("^(r[0-9]+|%s)$", 3420 valid_package_version_regexp), 3421 sub(dep_regexp, "\\4", dep))) 3422 bad_dep_version <- c(bad_dep_version, dep) 3423 } else if(!grepl(sprintf("^%s$", 3424 valid_package_version_regexp), 3425 sub(dep_regexp, "\\4", dep))) 3426 bad_dep_version <- c(bad_dep_version, dep) 3427 } 3428 } 3429 if(length(c(bad_dep_entry, bad_dep_op, bad_dep_version))) 3430 out$bad_depends_or_suggests_or_imports <- 3431 list(bad_dep_entry = bad_dep_entry, 3432 bad_dep_op = bad_dep_op, 3433 bad_dep_version = bad_dep_version) 3434 } 3435 if(strict && !is.na(val <- db["VignetteBuilder"])) { 3436 depends <- trimws(unlist(strsplit(val, ","))) 3437 if(length(depends) < 1L || !all(grepl("^[[:alnum:].]*$", depends))) 3438 out$bad_vignettebuilder <- TRUE 3439 } 3440 if(!is.na(val <- db["Priority"]) 3441 && !is.na(package_name) 3442 && (tolower(val) %in% c("base", "recommended", "defunct-base")) 3443 && (package_name %notin% unlist(standard_package_names))) 3444 out$bad_priority <- val 3445 3446 ## Minimal check (so far) of Title and Description. 3447 if(strict && !is.na(val <- db["Title"]) 3448 && endsWith(val, ".") 3449 && !grepl("[[:space:]][.][.][.]|et[[:space:]]al[.]", trimws(val))) 3450 out$bad_Title <- TRUE 3451 ## some people put punctuation inside quotes, some outside. 3452 if(strict && !is.na(val <- db["Description"]) 3453 && !grepl("[.!?]['\")]?$", trimws(val))) 3454 out$bad_Description <- TRUE 3455 3456 class(out) <- "check_package_description" 3457 out 3458} 3459 3460format.check_package_description <- 3461function(x, ...) 3462{ 3463 fmt <- function(x) { 3464 if(length(x)) paste(x, collapse = "\n") else character() 3465 } 3466 3467 ## <FIXME> 3468 ## Currently, check_meta() will give an error unless all output 3469 ## matches "^Malformed (Title|Description)", so for now need to 3470 ## avoid the pointer to R-exts in these cases. 3471 xx <- x; xx$bad_Title <- xx$bad_Description <- NULL 3472 ## </FIXME> 3473 3474 c(character(), 3475 if(length(x$missing_encoding)) 3476 gettext("Unknown encoding"), 3477 if(length(y <- x$fields_with_non_ASCII_tags)) 3478 paste(c(gettext("Fields with non-ASCII tags:"), 3479 .strwrap22(y), 3480 gettext("All field tags must be ASCII.")), 3481 collapse = "\n"), 3482 if(length(y <- x$fields_with_non_ASCII_values)) 3483 paste(c(gettext("Fields with non-ASCII values:"), 3484 .strwrap22(y), 3485 gettext("These fields must have ASCII values.")), 3486 collapse = "\n"), 3487 fmt(.format_check_package_description_authors_at_R_field_results(x)), 3488 ## if(length(y <- x$missing_required_fields)) 3489 ## paste(c(gettext("Required fields missing or empty:"), 3490 ## .strwrap22(y)), 3491 ## collapse = "\n"), 3492 if(length(x$bad_package)) 3493 paste(x$bad_package, collapse = "\n"), 3494 if(length(x$bad_version)) 3495 gettext("Malformed package version."), 3496 if(length(x$bad_maintainer)) 3497 gettext("Malformed maintainer field."), 3498 if(any(as.integer(lengths(x$bad_depends_or_suggests_or_imports)) > 0L )) { 3499 bad <- x$bad_depends_or_suggests_or_imports 3500 paste(c(gettext("Malformed Depends or Suggests or Imports or Enhances field."), 3501 if(length(y <- bad$bad_dep_entry)) 3502 c(gettext("Offending entries:"), 3503 paste0(" ", y), 3504 strwrap(gettextf("Entries must be names of packages optionally followed by '<=' or '>=', white space, and a valid version number in parentheses."))), 3505 if(length(y <- bad$bad_dep_op)) 3506 c(gettext("Entries with infeasible comparison operator:"), 3507 paste0(" ", y), 3508 strwrap(gettextf("Only operators '<=' and '>=' are possible."))), 3509 if(length(y <- bad$bad_dep_version)) 3510 c(gettext("Entries with infeasible version number:"), 3511 paste0(" ", y), 3512 strwrap(gettextf("Version numbers must be sequences of at least two non-negative integers, separated by single '.' or '-'.")))), 3513 collapse = "\n") 3514 }, 3515 if(isTRUE(x$bad_vignettebuilder)) 3516 paste(c(gettext("Invalid VignetteBuilder field."), 3517 strwrap(gettextf("This field must contain one or more packages (and no version requirement)."))), 3518 collapse = "\n"), 3519 if(length(x$bad_priority)) 3520 paste(c(gettext("Invalid Priority field."), 3521 strwrap(gettextf("Packages with priorities 'base' or 'recommended' or 'defunct-base' must already be known to R."))), 3522 collapse = "\n"), 3523 fmt(c(if(isTRUE(x$bad_Title)) 3524 gettext("Malformed Title field: should not end in a period."), 3525 if(isTRUE(x$bad_Description)) 3526 gettext("Malformed Description field: should contain one or more complete sentences."))), 3527 if(any(as.integer(lengths(xx)) > 0L)) 3528 paste(c(strwrap(gettext("See section 'The DESCRIPTION file' in the 'Writing R Extensions' manual."))), 3529 collapse = "\n")) 3530} 3531 3532print.check_package_description <- 3533function(x, ...) 3534{ 3535 if(length(y <- format(x, ...))) 3536 writeLines(paste(y, collapse = "\n\n")) 3537 invisible(x) 3538} 3539 3540 3541### * .check_package_description2 3542 3543.check_package_description2 <- 3544function(dfile) 3545{ 3546 dfile <- file_path_as_absolute(dfile) 3547 db <- .read_description(dfile) 3548 depends <- .get_requires_from_package_db(db, "Depends") 3549 imports <- .get_requires_from_package_db(db, "Imports") 3550 suggests <- .get_requires_from_package_db(db, "Suggests") 3551 enhances <- .get_requires_from_package_db(db, "Enhances") 3552 allpkgs <- c(depends, imports, suggests, enhances) 3553 out <- unique(allpkgs[duplicated(allpkgs)]) 3554 links <- missing_incs <- character() 3555 llinks <- .get_requires_with_version_from_package_db(db, "LinkingTo") 3556 have_src <- TRUE # dummy 3557 if(length(llinks)) { 3558 ## This is pointless unless there is compilable code 3559 have_src <- dir.exists(file.path(dirname(dfile), "src")) 3560 3561 ## See if this is installable under 3.0.1: 3562 ## if so check for versioned specs 3563 deps <- .split_description(db, verbose = TRUE)$Rdepends2 3564 status <- 0L 3565 current <- as.numeric_version("3.0.1") 3566 for(depends in deps) { 3567 if(depends$op %notin% c("<=", ">=", "<", ">", "==", "!=")) next 3568 status <- if(inherits(depends$version, "numeric_version")) 3569 !do.call(depends$op, list(current, depends$version)) 3570 else { 3571 ver <- R.version 3572 if (ver$status %in% c("", "Patched")) FALSE 3573 else !do.call(depends$op, 3574 list(ver[["svn rev"]], 3575 as.numeric(sub("^r", "", depends$version)))) 3576 } 3577 } 3578 if(!status) { 3579 llinks <- llinks[lengths(llinks) > 1L] 3580 if(length(llinks)) links <- sapply(llinks, `[[`, 1L) 3581 } 3582 ## and check if we can actually link to these. 3583 llinks <- .get_requires_from_package_db(db, "LinkingTo") 3584 incs <- lapply(llinks, function(x) system.file("include", package = x)) 3585 missing_incs <- as.vector(llinks[!nzchar(incs)]) 3586 } 3587 out <- list(duplicates = unique(allpkgs[duplicated(allpkgs)]), 3588 bad_links = links, missing_incs = missing_incs, 3589 have_src = have_src) 3590 class(out) <- "check_package_description2" 3591 out 3592} 3593 3594format.check_package_description2 <- function(x, ...) 3595{ 3596 c(if(length(xx <- x$duplicates)) { 3597 c(if(length(xx) > 1L) 3598 "Packages listed in more than one of Depends, Imports, Suggests, Enhances:" 3599 else 3600 "Package listed in more than one of Depends, Imports, Suggests, Enhances:", 3601 paste(c(" ", sQuote(xx)), collapse = " "), 3602 "A package should be listed in only one of these fields.") 3603 }, 3604 if(!x$have_src) "'LinkingTo' field is unused: package has no 'src' directory", 3605 if(length(xx <- x$bad_links)) { 3606 if(length(xx) > 1L) 3607 c("Versioned 'LinkingTo' values for", 3608 paste(c(" ", sQuote(xx)), collapse = " "), 3609 "are only usable in R >= 3.0.2") 3610 else 3611 sprintf("Versioned 'LinkingTo' value for %s is only usable in R >= 3.0.2", 3612 sQuote(xx)) 3613 }, 3614 if(x$have_src && length(xx <- x$missing_incs)) { 3615 if(length(xx) > 1L) 3616 c("'LinkingTo' for", 3617 paste(c(" ", sQuote(xx)), collapse = " "), 3618 "are unused as they have no 'include' directory") 3619 else 3620 sprintf("'LinkingTo' for %s is unused as it has no 'include' directory", sQuote(xx)) 3621 }) 3622} 3623 3624.check_package_description_authors_at_R_field <- 3625function(aar, strict = FALSE) 3626{ 3627 out <- list() 3628 if(is.na(aar)) return(out) 3629 aar <- tryCatch(utils:::.read_authors_at_R_field(aar), 3630 error = identity) 3631 if(inherits(aar, "error")) { 3632 out$bad_authors_at_R_field <- conditionMessage(aar) 3633 } else { 3634 ## Check whether we can expand to something non-empty. 3635 s <- tryCatch(utils:::.format_authors_at_R_field_for_author(aar), 3636 error = identity) 3637 if(inherits(s, "error")) { 3638 out$bad_authors_at_R_field_for_author <- 3639 conditionMessage(s) 3640 } else { 3641 if(s == "") 3642 out$bad_authors_at_R_field_has_no_author <- TRUE 3643 else { 3644 attr(out, "Author") <- s 3645 if(strict >= 1L) { 3646 has_no_name <- 3647 vapply(aar, 3648 function(e) 3649 is.null(e$given) && is.null(e$family), 3650 NA) 3651 if(any(has_no_name)) { 3652 out$bad_authors_at_R_field_has_persons_with_no_name <- 3653 format(aar[has_no_name]) 3654 } 3655 has_no_role <- 3656 vapply(aar, 3657 function(e) is.null(e$role), 3658 NA) 3659 if(any(has_no_role)) { 3660 out$bad_authors_at_R_field_has_persons_with_no_role <- 3661 format(aar[has_no_role]) 3662 } 3663 } 3664 if(strict >= 2L) { 3665 if(all(has_no_name | 3666 vapply(aar, function(e) "aut" %notin% e$role, NA))) 3667 out$bad_authors_at_R_field_has_no_author_roles <- TRUE 3668 has_bad_ORCID_identifiers <- 3669 vapply(aar, 3670 function(e) { 3671 e <- e$comment 3672 e <- e[names(e) == "ORCID"] 3673 any(!grepl(.ORCID_iD_variants_regexp, 3674 e)) 3675 }, 3676 NA) 3677 if(any(has_bad_ORCID_identifiers)) 3678 out$bad_authors_at_R_field_has_persons_with_bad_ORCID_identifiers <- 3679 format(aar[has_bad_ORCID_identifiers]) 3680 } 3681 if(strict >= 3L) { 3682 non_standard_roles <- 3683 lapply(aar$role, setdiff, 3684 utils:::MARC_relator_db_codes_used_with_R) 3685 ind <- lengths(non_standard_roles) > 0L 3686 if(any(ind)) { 3687 out$authors_at_R_field_has_persons_with_nonstandard_roles <- 3688 sprintf("%s: %s", 3689 format(aar[ind]), 3690 vapply(non_standard_roles[ind], paste, 3691 collapse = ", ", 3692 FUN.VALUE = "")) 3693 } 3694 } 3695 } 3696 } 3697 s <- tryCatch(utils:::.format_authors_at_R_field_for_maintainer(aar), 3698 error = identity) 3699 if(inherits(s, "error")) { 3700 out$bad_authors_at_R_field_for_maintainer <- 3701 conditionMessage(s) 3702 } else { 3703 ## R-exts says 3704 ## The mandatory 'Maintainer' field should give a _single_ 3705 ## name followed by a _valid_ (RFC 2822) email address in 3706 ## angle brackets. 3707 ## Hence complain when Authors@R 3708 ## * has more than one person with a cre role 3709 ## * has no person with a cre role, "valid" email address 3710 ## and a non-empty name. 3711 bad <- FALSE 3712 p <- Filter(function(e) "cre" %in% e$role, 3713 aar) 3714 if(length(p) > 1L) { 3715 bad <- TRUE 3716 out$bad_authors_at_R_field_too_many_maintainers <- 3717 format(p) 3718 } 3719 p <- Filter(function(e) { 3720 (!is.null(e$given) || !is.null(e$family)) && !is.null(e$email) 3721 }, 3722 p) 3723 if(!length(p)) { 3724 bad <- TRUE 3725 out$bad_authors_at_R_field_has_no_valid_maintainer <- TRUE 3726 } 3727 ## s should now be non-empty iff bad is FALSE. 3728 if(!bad) attr(out, "Maintainer") <- s 3729 } 3730 } 3731 out 3732} 3733 3734.format_check_package_description_authors_at_R_field_results <- 3735function(x) 3736{ 3737 c(character(), 3738 if(length(bad <- x[["bad_authors_at_R_field"]])) { 3739 c(gettext("Malformed Authors@R field:"), 3740 paste0(" ", bad)) 3741 }, 3742 if(length(bad <- x[["bad_authors_at_R_field_for_author"]])) { 3743 c(gettext("Cannot extract Author field from Authors@R field:"), 3744 paste0(" ", bad)) 3745 }, 3746 if(length(x[["bad_authors_at_R_field_has_no_author"]])) { 3747 gettext("Authors@R field gives no person with name and roles.") 3748 }, 3749 if(length(bad <- 3750 x[["bad_authors_at_R_field_has_persons_with_no_name"]])) { 3751 c(gettext("Authors@R field gives persons with no name:"), 3752 paste0(" ", bad)) 3753 }, 3754 if(length(bad <- 3755 x[["bad_authors_at_R_field_has_persons_with_no_role"]])) { 3756 c(gettext("Authors@R field gives persons with no role:"), 3757 paste0(" ", bad)) 3758 }, 3759 if(length(x[["bad_authors_at_R_field_has_no_author_roles"]])) { 3760 gettext("Authors@R field gives no person with name and author role") 3761 }, 3762 ## if(length(bad <- 3763 ## x[["authors_at_R_field_has_persons_with_nonstandard_roles"]])) { 3764 ## c(gettext("Authors@R field gives persons with non-standard roles:"), 3765 ## paste0(" ", bad)) 3766 ## }, 3767 if(length(bad <- x[["bad_authors_at_R_field_for_maintainer"]])) { 3768 c(gettext("Cannot extract Maintainer field from Authors@R field:"), 3769 paste0(" ", bad)) 3770 }, 3771 if(length(bad <- 3772 x[["bad_authors_at_R_field_too_many_maintainers"]])) { 3773 c(gettext("Authors@R field gives more than one person with maintainer role:"), 3774 paste0(" ", bad)) 3775 }, 3776 if(length(x[["bad_authors_at_R_field_has_no_valid_maintainer"]])) { 3777 strwrap(gettext("Authors@R field gives no person with maintainer role, valid email address and non-empty name.")) 3778 }, 3779 if(length(bad <- x[["bad_authors_at_R_field_has_persons_with_bad_ORCID_identifiers"]])) { 3780 c(gettext("Authors@R field gives persons with invalid ORCID identifiers:"), 3781 paste0(" ", bad)) 3782 } 3783 ) 3784} 3785 3786### * .check_package_description_encoding 3787 3788.check_package_description_encoding <- 3789function(dfile) 3790{ 3791 dfile <- file_path_as_absolute(dfile) 3792 db <- .read_description(dfile) 3793 out <- list() 3794 3795 ## Check encoding-related things. 3796 3797 ## All field tags must be ASCII. 3798 if(any(ind <- !.is_ASCII(names(db)))) 3799 out$fields_with_non_ASCII_tags <- names(db)[ind] 3800 3801 if("Encoding" %notin% names(db)) { 3802 ind <- !.is_ASCII(db) 3803 if(any(ind)) { 3804 out$missing_encoding <- TRUE 3805 out$fields_with_non_ASCII_values <- names(db)[ind] 3806 } 3807 } else { 3808 enc <- db[["Encoding"]] 3809 if (enc %notin% c("latin1", "latin2", "UTF-8")) 3810 out$non_portable_encoding <- enc 3811 } 3812 3813 class(out) <- "check_package_description_encoding" 3814 out 3815} 3816 3817format.check_package_description_encoding <- 3818function(x, ...) 3819{ 3820 c(character(), 3821 if(length(x$non_portable_encoding)) { 3822 c(gettextf("Encoding '%s' is not portable", 3823 x$non_portable_encoding), 3824 "") 3825 }, 3826 if(length(x$missing_encoding)) { 3827 gettext("Unknown encoding with non-ASCII data") 3828 }, 3829 if(length(x$fields_with_non_ASCII_tags)) { 3830 c(gettext("Fields with non-ASCII tags:"), 3831 .pretty_format(x$fields_with_non_ASCII_tags), 3832 gettext("All field tags must be ASCII."), 3833 "") 3834 }, 3835 if(length(x$fields_with_non_ASCII_values)) { 3836 c(gettext("Fields with non-ASCII values:"), 3837 .pretty_format(x$fields_with_non_ASCII_values)) 3838 }, 3839 if(any(as.integer(lengths(x)) > 0L)) { 3840 c(strwrap(gettextf("See section 'The DESCRIPTION file' in the 'Writing R Extensions' manual.")), 3841 "") 3842 }) 3843} 3844 3845### * .check_package_license 3846 3847.check_package_license <- 3848function(dfile, dir) 3849{ 3850 dfile <- file_path_as_absolute(dfile) 3851 db <- .read_description(dfile) 3852 3853 if(missing(dir)) 3854 dir <- dirname(dfile) 3855 3856 ## Analyze the license information here. 3857 ## Cannot easily do this in .check_package_description(), as R CMD 3858 ## check's R::Utils::check_package_description() takes any output 3859 ## from this as indication of an error. 3860 3861 out <- list() 3862 if(!is.na(val <- db["License"])) { 3863 ## If there is no License field, .check_package_description() 3864 ## will give an error. 3865 status <- analyze_license(val) 3866 ok <- status$is_canonical 3867 ## This analyzes the license specification but does not verify 3868 ## whether pointers exist, so let us do this here. 3869 if(length(pointers <- status$pointers)) { 3870 bad_pointers <- 3871 pointers[!file_test("-f", file.path(dir, pointers))] 3872 if(length(bad_pointers)) { 3873 status$bad_pointers <- bad_pointers 3874 ok <- FALSE 3875 } 3876 } 3877 patt <- "(^Modified BSD License$|^BSD$|^CC BY.* [23][.]0)" 3878 if(any(ind <- grepl(patt, status$component))) { 3879 status$deprecated <- status$components[ind] 3880 ok <- FALSE 3881 } 3882 ## Components with extensions but not extensible: 3883 if(length(extensions <- status$extensions) && 3884 any(ind <- !extensions$extensible)) { 3885 status$bad_extensions <- extensions$components[ind] 3886 ok <- FALSE 3887 } 3888 ## Components which need extensions (note that such components 3889 ## could use the name or abbrev from the license db): 3890 if(any(ind <- status$components %in% 3891 c("MIT License", "MIT", 3892 "BSD 2-clause License", "BSD_2_clause", 3893 "BSD 3-clause License", "BSD_3_clause"))) { 3894 status$miss_extension <- status$components[ind] 3895 ok <- FALSE 3896 } 3897 ## Could always return the analysis results and not print them 3898 ## if ok, but it seems more standard to only return trouble. 3899 if(!ok) 3900 out <- c(list(license = val), status) 3901 } 3902 3903 class(out) <- "check_package_license" 3904 out 3905} 3906 3907format.check_package_license <- 3908function(x, ...) 3909{ 3910 if(!length(x)) 3911 return(character()) 3912 3913 check <- Sys.getenv("_R_CHECK_LICENSE_") 3914 check <- if(check %in% c("maybe", "")) 3915 (!(x$is_standardizable) 3916 || length(x$bad_pointers) 3917 || length(x$bad_extensions)) 3918 else 3919 isTRUE(as.logical(check)) 3920 if(!check) 3921 return(character()) 3922 3923 c(character(), 3924 if(!(x$is_canonical)) { 3925 c(gettext("Non-standard license specification:"), 3926 strwrap(x$license, indent = 2L, exdent = 2L), 3927 gettextf("Standardizable: %s", x$is_standardizable), 3928 if(x$is_standardizable) { 3929 c(gettext("Standardized license specification:"), 3930 strwrap(x$standardization, indent = 2L, exdent = 2L)) 3931 }) 3932 }, 3933 if(length(y <- x$deprecated)) { 3934 c(gettextf("Deprecated license: %s", 3935 paste(y, collapse = " "))) 3936 }, 3937 if(length(y <- x$bad_pointers)) { 3938 c(gettextf("Invalid license file pointers: %s", 3939 paste(y, collapse = " "))) 3940 }, 3941 if(length(y <- x$bad_extensions)) { 3942 c(gettext("License components with restrictions not permitted:"), 3943 paste0(" ", y)) 3944 }, 3945 if(length(y <- x$miss_extension)) { 3946 c(gettext("License components which are templates and need '+ file LICENSE':"), 3947 paste0(" ", y)) 3948 } 3949 ) 3950} 3951 3952### * .check_make_vars 3953 3954.check_make_vars <- 3955function(dir, makevars = c("Makevars.in", "Makevars")) 3956{ 3957 bad_flags <- list() 3958 class(bad_flags) <- "check_make_vars" 3959 3960 paths <- file.path(dir, makevars) 3961 paths <- paths[file_test("-f", paths)] 3962 if(!length(paths)) return(bad_flags) 3963 bad_flags$paths <- file.path("src", basename(paths)) 3964 ## Makevars could be used with --no-configure 3965 ## and maybe configure does not even use src/Makevars.in 3966 mfile <- paths[1L] 3967 make <- Sys.getenv("MAKE") 3968 if(make == "") make <- "make" 3969 ## needs a target to avoid targets in src/Makevars 3970 command <- sprintf("%s -f %s -f %s -f %s makevars_test", 3971 make, 3972 shQuote(file.path(R.home("share"), "make", 3973 "check_vars_ini.mk")), 3974 shQuote(mfile), 3975 shQuote(file.path(R.home("share"), "make", 3976 "check_vars_out.mk"))) 3977 lines <- suppressWarnings(tryCatch(system(command, intern = TRUE, 3978 ignore.stderr = TRUE), 3979 error = identity)) 3980 if(!length(lines) || inherits(lines, "error")) 3981 return(bad_flags) 3982 3983 prefixes <- c("CPP", "C", "CXX", "CXX98", "CXX11", "CXX14", "CXX17", 3984 "CXX20", "F", "FC", "OBJC", "OBJCXX") 3985 3986 uflags_re <- sprintf("^(%s)FLAGS: *(.*)$", 3987 paste(prefixes, collapse = "|")) 3988 pos <- grep(uflags_re, lines) 3989 ind <- (sub(uflags_re, "\\2", lines[pos]) != "-o /dev/null") 3990 if(any(ind)) 3991 bad_flags$uflags <- lines[pos[ind]] 3992 3993 ## Try to be careful ... 3994 pflags_re <- sprintf("^PKG_(%s)FLAGS: ", 3995 paste(prefixes, collapse = "|")) 3996 lines <- lines[grepl(pflags_re, lines)] 3997 names <- sub(":.*", "", lines) 3998 lines <- sub(pflags_re, "", lines) 3999 flags <- strsplit(lines, "[[:space:]]+") 4000 ## Bad flags: 4001 ## -O* 4002 ## (BDR: for example Sun Fortran compilers used to accept -O 4003 ## but not -O2, and VC++ accepts -Ox (literal x) but not -O.) 4004 ## -Wall -pedantic -ansi -traditional -std* -f* -m* [GCC] 4005 ## -x [Solaris] 4006 ## -q [AIX] 4007 ## It is hard to think of anything apart from -I* and -D* that is 4008 ## safe for general use ... 4009 bad_flags_regexp <- 4010 sprintf("^-(%s)$", 4011 paste(c("O.*", 4012 "W", # same as -Wextra in GCC. 4013 "w", # GCC, Solaris inhibit all warnings 4014 "W[^l].*", # -Wl, might just be portable 4015 "ansi", "pedantic", "traditional", 4016 "f.*", "m.*", "std.*", # includes -fopenmp 4017 "isystem", # gcc and clones 4018 "x", 4019 "cpp", # gfortran 4020 "g", # not portable, waste of space 4021 "q"), 4022 collapse = "|")) 4023 for(i in seq_along(lines)) { 4024 bad <- grep(bad_flags_regexp, flags[[i]], value = TRUE) 4025 if(length(bad)) 4026 bad_flags$pflags <- 4027 c(bad_flags$pflags, 4028 structure(list(bad), names = names[i])) 4029 } 4030 4031 ## The above does not know about GNU extensions like 4032 ## target.o: PKG_CXXFLAGS = -mavx 4033 ## so grep files directly. 4034 for (f in paths) { 4035 lines <- readLines(f, warn = FALSE) 4036 pflags_re2 <- sprintf(".*[.o]: +PKG_(%s)FLAGS *=", 4037 paste(prefixes, collapse = "|")) 4038 lines <- grep(pflags_re2, lines, value = TRUE) 4039 lines <- sub(pflags_re2, "", lines) 4040 flags <- strsplit(lines, "[[:space:]]+") 4041 bad <- character() 4042 for(i in seq_along(lines)) 4043 bad <- c(bad, grep(bad_flags_regexp, flags[[i]], value = TRUE)) 4044 4045 if(length(bad)) 4046 bad_flags$p2flags <- 4047 c(bad_flags$p2flags, 4048 structure(list(bad), names = file.path("src", basename(f)))) 4049 } 4050 4051 bad_flags 4052} 4053 4054format.check_make_vars <- 4055function(x, ...) 4056{ 4057 .fmt <- function(x) { 4058 s <- Map(c, 4059 gettextf("Non-portable flags in variable '%s':", 4060 names(x)), 4061 sprintf(" %s", lapply(x, paste, collapse = " "))) 4062 as.character(unlist(s)) 4063 } 4064 4065 .fmt2 <- function(x) { 4066 s <- Map(c, 4067 gettextf("Non-portable flags in file '%s':", 4068 names(x)), 4069 sprintf(" %s", lapply(x, paste, collapse = " "))) 4070 as.character(unlist(s)) 4071 } 4072 4073 c(character(), 4074 if(length(bad <- x$pflags)) .fmt(bad), 4075 if(length(bad <- x$p2flags)) .fmt2(bad), 4076 if(length(bad <- x$uflags)) { 4077 c(gettextf("Variables overriding user/site settings:"), 4078 sprintf(" %s", bad)) 4079 }, 4080 if(length(x$paths) > 1L) { 4081 c(sprintf("Package has both %s and %s.", 4082 sQuote("src/Makevars.in"), sQuote("src/Makevars")), 4083 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.", 4084 sQuote("src/Makevars"), 4085 sQuote("src/Makevars.win"), 4086 sQuote("configure"), 4087 sQuote("src/Makevars"), 4088 sQuote("cleanup")))) 4089 }) 4090} 4091 4092### * .check_code_usage_in_package 4093 4094## First, its auxiliaries 4095## 4096## - .unix_only_proto_objects 4097## - .windows_only_proto_objects 4098## - compatibilityEnv () -- used also in codoc() 4099 4100.unix_only_proto_objects <- as.environment(list( 4101 nsl = function(hostname) {} 4102 , X11Font = function(font) {} 4103 , X11Fonts = function(...) {} 4104 , X11.options = function(..., reset = TRUE) {} 4105 , quartz = function(title, width, height, pointsize, family, 4106 fontsmooth, antialias, type, file = NULL, 4107 bg, canvas, dpi) {} 4108 , quartzFont = function(family) {} 4109 , quartzFonts = function(...) {} 4110 , quartz.options = function(..., reset = TRUE) {} 4111 , quartz.save = function(file, type = "png", device = dev.cur(), 4112 dpi = 100, ...) {} 4113)) 4114 4115.windows_only_proto_objects <- as.environment(list( 4116 arrangeWindows = function(action = c("vertical", "horizontal", 4117 "cascade", "minimize", "restore"), 4118 windows, preserve = TRUE, outer = FALSE) {} 4119 , askYesNoWinDialog = function(msg, ...) {} 4120 , bringToTop = function(which = grDevices::dev.cur(), stay = FALSE) {} 4121 , choose.dir = function(default = "", caption = "Select folder") {} 4122 , choose.files = function(default = "", caption = "Select files", multi = TRUE, 4123 filters = Filters, index = nrow(Filters)) { 4124 Filters <- NULL } 4125 , Filters = NULL 4126 , close.winProgressBar = function(con, ...) {} 4127 , DLL.version = function(path) {} 4128 , .fixupGFortranStderr = function() {} 4129 , .fixupGFortranStdout = function() {} 4130 , getClipboardFormats = function(numeric = FALSE) {} 4131 , getIdentification = function() {} 4132 , getWindowsHandle = function(which = "Console") {} 4133 , getWindowsHandles = function(which = "R", pattern = "", minimized = FALSE) {} 4134 , getWindowTitle = function() {} 4135 , getWinProgressBar = function(pb) {} 4136 , .install.winbinary = function(pkgs, lib, repos = getOption("repos"), 4137 contriburl = utils::contrib.url(repos), 4138 method, available = NULL, destdir = NULL, 4139 dependencies = FALSE, libs_only = FALSE, ...) {} 4140 , loadRconsole = function(file = choose.files(file.path( 4141 Sys.getenv("R_USER"), "Rconsole"))) {} 4142 , msgWindow = function(type = c("minimize", "restore", "maximize", "hide", 4143 "recordOn", "recordOff"), 4144 which = dev.cur()) {} 4145 , readClipboard = function(format = 1, raw = FALSE) {} 4146 , readRegistry = function(key, 4147 hive = c("HLM", "HCR", "HCU", "HU", "HCC", "HPD"), 4148 maxdepth = 1, 4149 view = c("default", "32-bit", "64-bit")) {} 4150 ## Exists on all platforms though with differing formals : 4151 ## , savePlot = function(filename = "Rplot", 4152 ## type = c("wmf", "emf", "png", "jpeg", "jpg", 4153 ## "bmp", "ps", "eps", "pdf"), 4154 ## device = grDevices::dev.cur(), restoreConsole = TRUE) {} 4155 , setStatusBar = function(text) {} 4156 , setWindowTitle = function(suffix, title = paste(utils::getIdentification(), 4157 suffix)) {} 4158 , setWinProgressBar = function(pb, value, title=NULL, label=NULL) {} 4159 , shell = function(cmd, shell, flag = "/c", intern = FALSE, 4160 wait = TRUE, translate = FALSE, mustWork = FALSE, ...) {} 4161 , shell.exec = function(file) {} 4162 , shortPathName = function(path) {} 4163 , Sys.junction = function(from, to) {} 4164 , win.graph = function(width = 7, height = 7, pointsize = 12, 4165 restoreConsole = FALSE) {} 4166 , win.metafile = function(filename = "", width = 7, height = 7, 4167 pointsize = 12, family = "", 4168 restoreConsole = TRUE) {} 4169 , win.print = function(width = 7, height = 7, pointsize = 12, 4170 printer = "", family = "", antialias = "default", 4171 restoreConsole = TRUE) {} 4172 , win.version = function() {} 4173 , windows = function(width, height, pointsize, 4174 record, rescale, xpinch, ypinch, 4175 bg, canvas, gamma, xpos, ypos, 4176 buffered, title, restoreConsole, clickToConfirm, 4177 fillOddEven, family = "", antialias) {} 4178 , windowsFont = function(font) {} 4179 , windowsFonts = function(...) {} 4180 , windows.options = function(..., reset = TRUE) {} 4181 , winDialog = function(type = "ok", message) {} 4182 , winDialogString = function(message, default) {} 4183 , winMenuAdd = function(menuname) {} 4184 , winMenuAddItem = function(menuname, itemname, action) {} 4185 , winMenuDel = function(menuname) {} 4186 , winMenuDelItem = function(menuname, itemname) {} 4187 , winMenuNames = function() {} 4188 , winMenuItems = function(menuname) {} 4189 , winProgressBar = function(title = "R progress bar", label = "", 4190 min = 0, max = 1, initial = 0, width = 300) {} 4191 , writeClipboard = function(str, format = 1L) {} 4192 , zip.unpack = function(zipname, dest) {} 4193)) 4194 4195compatibilityEnv <- function() { 4196 ## (this formulation allows more than two OS.type s) 4197 switch(.Platform$OS.type, 4198 "windows" = .unix_only_proto_objects, 4199 "unix" = .windows_only_proto_objects, 4200 ## in such a future case, possibly the "union" of these environments: 4201 stop(gettextf("invalid 'OS.type' \"%s\". Should not happen"))) 4202} 4203 4204.check_code_usage_in_package <- 4205function(package, lib.loc = NULL) 4206{ 4207 is_base <- package == "base" 4208 4209 check_without_loading <- 4210 config_val_to_logical(Sys.getenv("_R_CHECK_CODE_USAGE_VIA_NAMESPACES_", 4211 "TRUE")) 4212 4213 if(!is_base) { 4214 if(!check_without_loading) { 4215 .load_package_quietly(package, lib.loc) 4216 .eval_with_capture({ 4217 ## avoid warnings about code in other packages the package 4218 ## uses 4219 desc <- readRDS(file.path(find.package(package, NULL), 4220 "Meta", "package.rds")) 4221 pkgs1 <- sapply(desc$Suggests, "[[", "name") 4222 pkgs2 <- sapply(desc$Enhances, "[[", "name") 4223 for(pkg in unique(c(pkgs1, pkgs2))) 4224 ## tcltk warns if no DISPLAY variable 4225 ##, errors if not compiled in 4226 suppressMessages( 4227 tryCatch(require(pkg, character.only = TRUE, 4228 quietly = TRUE), 4229 error = function(.) NULL, 4230 warning= function(.) NULL)) 4231 }, type = "output") 4232 } 4233 if(is.null(.GlobalEnv$.Random.seed)) # create .Random.seed if necessary 4234 stats::runif(1) 4235 attach(compatibilityEnv(), name="compat", pos = length(search()), 4236 warn.conflicts = FALSE) 4237 on.exit(detach("compat")) 4238 } 4239 4240 ## A simple function for catching the output from the codetools 4241 ## analysis using the checkUsage report mechanism. 4242 out <- character() 4243 foo <- function(x) out <<- c(out, x) 4244 ## (Simpler than using a variant of capture.output().) 4245 ## Of course, it would be nice to return a suitably structured 4246 ## result, but we can always do this by suitably splitting the 4247 ## messages on the double colons ... 4248 4249 ## Not only check function definitions, but also S4 methods 4250 ## [a version of this should be part of codetools eventually] : 4251 checkMethodUsageEnv <- function(env, ...) { 4252 for(g in .get_S4_generics(env)) 4253 for(m in .get_S4_methods_list(g, env)) { 4254 fun <- methods::unRematchDefinition(methods::getDataPart(m)) 4255 signature <- paste(m@generic, 4256 paste(m@target, collapse = "-"), 4257 sep = ",") 4258 codetools::checkUsage(fun, signature, ...) 4259 } 4260 } 4261 checkMethodUsagePackage <- function (pack, ...) { 4262 pname <- paste0("package:", pack) 4263 if (pname %notin% search()) 4264 stop("package must be loaded", domain = NA) 4265 checkMethodUsageEnv(if (isNamespaceLoaded(pack)) 4266 getNamespace(pack) else as.environment(pname), ...) 4267 } 4268 4269 ## Allow specifying a codetools "profile" for checking via the 4270 ## environment variable _R_CHECK_CODETOOLS_PROFILE_, used as e.g. 4271 ## _R_CHECK_CODETOOLS_PROFILE_="suppressLocalUnused=FALSE" 4272 ## (where the values get converted to logicals "the usual way"). 4273 args <- list(skipWith = TRUE, 4274 suppressPartialMatchArgs = FALSE, 4275 suppressLocalUnused = TRUE) 4276 opts <- unlist(strsplit(Sys.getenv("_R_CHECK_CODETOOLS_PROFILE_"), 4277 "[[:space:]]*,[[:space:]]*")) 4278 if(length(opts)) { 4279 args[sub("[[:space:]]*=.*", "", opts)] <- 4280 lapply(sub(".*=[[:space:]]*", "", opts), 4281 config_val_to_logical) 4282 } 4283 if(check_without_loading) 4284 env <- suppressWarnings(suppressMessages(getNamespace(package))) 4285 ## look for globalVariables declaration in package 4286 ## (This loads the namespace if not already loaded.) 4287 .glbs <- suppressMessages(utils::globalVariables(, package)) 4288 if(length(.glbs)) { 4289 ## Cannot use globalVariables() for base 4290 ## (and potentially tools and utils) 4291 dflt <- c(if(package == "base") "last.dump", 4292 ".Generic", ".Method", ".Class") 4293 args$suppressUndefined <- c(dflt, .glbs) 4294 } 4295 4296 if(check_without_loading) { 4297 args <- c(list(env, report = foo), args) 4298 suppressMessages(do.call(codetools::checkUsageEnv, args)) 4299 suppressMessages(do.call(checkMethodUsageEnv, args)) 4300 } else { 4301 args <- c(list(package, report = foo), args) 4302 suppressMessages(do.call(codetools::checkUsagePackage, args)) 4303 suppressMessages(do.call(checkMethodUsagePackage, args)) 4304 } 4305 4306 out <- unique(out) 4307 class(out) <- "check_code_usage_in_package" 4308 out 4309} 4310 4311format.check_code_usage_in_package <- 4312function(x, ...) 4313{ 4314 if(length(x)) { 4315 ## There seems no easy we can gather usage diagnostics by type, 4316 ## so try to rearrange to some extent when formatting. 4317 ind <- grepl(": partial argument match of", x, fixed = TRUE) 4318 if(any(ind)) x <- c(x[ind], x[!ind]) 4319 } 4320 if(length(x)) { 4321 ## Provide a summary listing of the undefined globals: 4322 y <- .canonicalize_quotes(x) 4323 m <- regexec("no visible global function definition for '(.*)'", y) 4324 funs <- vapply(Filter(length, regmatches(y, m)), `[`, "", 2L) 4325 m <- regexec("no visible binding for global variable '(.*)'", y) 4326 vars <- vapply(Filter(length, regmatches(y, m)), `[`, "", 2L) 4327 y <- sort(unique(c(funs, vars))) 4328 c(strwrap(x, indent = 0L, exdent = 2L), 4329 if(length(y)) { 4330 c("Undefined global functions or variables:", 4331 strwrap(paste(y, collapse = " "), 4332 indent = 2L, exdent = 2L)) 4333 }) 4334 } else character() 4335} 4336 4337### * .check_Rd_xrefs 4338 4339.check_Rd_xrefs <- 4340function(package, dir, lib.loc = NULL) 4341{ 4342 ## Build a db with all possible link targets (aliases) in the base 4343 ## and recommended packages. 4344 base <- unlist(.get_standard_package_names()[c("base", "recommended")], 4345 use.names = FALSE) 4346 ## May not have recommended packages 4347 base <- base[dir.exists(file.path(.Library, base))] 4348 aliases <- lapply(base, Rd_aliases, lib.loc = NULL) 4349 ## (Don't use lib.loc = .Library, as recommended packages may have 4350 ## been installed to a different place.) 4351 4352 ## Now find the aliases in packages it depends on 4353 if(!missing(package)) { 4354 pfile <- system.file("Meta", "package.rds", package = package, 4355 lib.loc = lib.loc) 4356 pkgInfo <- readRDS(pfile) 4357 } else { 4358 outDir <- file.path(tempdir(), "fake_pkg") 4359 dir.create(file.path(outDir, "Meta"), FALSE, TRUE) 4360 .install_package_description(dir, outDir) 4361 pfile <- file.path(outDir, "Meta", "package.rds") 4362 pkgInfo <- readRDS(pfile) 4363 unlink(outDir, recursive = TRUE) 4364 } 4365 ## only 'Depends' are guaranteed to be on the search path, but 4366 ## 'Imports' have to be installed and hence help there will be found 4367 deps <- c(names(pkgInfo$Depends), names(pkgInfo$Imports)) 4368 pkgs <- setdiff(unique(deps), base) 4369 try_Rd_aliases <- function(...) tryCatch(Rd_aliases(...), error = identity) 4370 aliases <- c(aliases, lapply(pkgs, try_Rd_aliases, lib.loc = lib.loc)) 4371 aliases[vapply(aliases, inherits, "error", FUN.VALUE = NA)] <- NULL 4372 4373 ## Add the aliases from the package itself, and build a db with all 4374 ## (if any) \link xrefs in the package Rd objects. 4375 if(!missing(package)) { 4376 aliases1 <- Rd_aliases(package, lib.loc = lib.loc) 4377 if(!length(aliases1)) 4378 return(structure(list(), class = "check_Rd_xrefs")) 4379 aliases <- c(aliases, list(aliases1)) 4380 db <- .build_Rd_xref_db(package, lib.loc = lib.loc) 4381 } else { 4382 aliases1 <- Rd_aliases(dir = dir) 4383 if(!length(aliases1)) 4384 return(structure(list(), class = "check_Rd_xrefs")) 4385 aliases <- c(aliases, list(aliases1)) 4386 db <- .build_Rd_xref_db(dir = dir) 4387 } 4388 4389 ## Flatten the xref db into one big matrix. 4390 db <- cbind(do.call("rbind", db), 4391 File = rep.int(names(db), vapply(db, NROW, 0L))) 4392 if(nrow(db) == 0L) 4393 return(structure(list(), class = "check_Rd_xrefs")) 4394 4395 ## fixup \link[=dest] form 4396 anchor <- db[, 2L] 4397 have_equals <- startsWith(anchor, "=") 4398 if(any(have_equals)) 4399 db[have_equals, 1:2] <- cbind(sub("^=", "", anchor[have_equals]), "") 4400 4401 db <- cbind(db, bad = FALSE, report = db[, 1L]) 4402 have_anchor <- nzchar(anchor <- db[, 2L]) 4403 db[have_anchor, "report"] <- 4404 paste0("[", db[have_anchor, 2L], "]{", db[have_anchor, 1L], "}") 4405 4406 ## Check the targets from the non-anchored xrefs. 4407 db[!have_anchor, "bad"] <- db[!have_anchor, 1L] %notin% unlist(aliases) 4408 4409 ## and then check the anchored ones if we can. 4410 have_colon <- grepl(":", anchor, fixed = TRUE) 4411 unknown <- character() 4412 thispkg <- anchor 4413 thisfile <- db[, 1L] 4414 thispkg [have_colon] <- sub("([^:]*):(.*)", "\\1", anchor[have_colon]) 4415 thisfile[have_colon] <- sub("([^:]*):(.*)", "\\2", anchor[have_colon]) 4416 4417 use_aliases_from_CRAN <- 4418 config_val_to_logical(Sys.getenv("_R_CHECK_XREFS_USE_ALIASES_FROM_CRAN_", 4419 "FALSE")) 4420 if(use_aliases_from_CRAN) { 4421 aliases_db <- NULL 4422 } 4423 4424 anchors <- unique(thispkg[have_anchor]) 4425 4426 ## added in 4.1.0: are anchors declared? 4427 check_anchors <- 4428 config_val_to_logical(Sys.getenv("_R_CHECK_XREFS_PKGS_ARE_DECLARED_", 4429 "FALSE")) 4430 if(check_anchors) { 4431 deps2 <- c(names(pkgInfo$Depends), names(pkgInfo$Imports), 4432 names(pkgInfo$Suggests)) 4433 ## people link to the package itself, although never needed. 4434 undeclared <- setdiff(anchors, c(unique(deps2), package, base)) 4435 if(length(undeclared)) { 4436 ## Now dig out Enhances 4437 DESC <- pkgInfo$DESCRIPTION 4438 if("Enhances" %in% names(DESC)) { 4439 enh <- names(.split_dependencies(DESC[["Enhances"]])) 4440 undeclared <- setdiff(undeclared, enh) 4441 } 4442 } 4443 if(length(undeclared)) 4444 message(sprintf(ngettext(length(undeclared), 4445 "Undeclared package %s in Rd xrefs", 4446 "Undeclared packages %s in Rd xrefs"), 4447 paste(sQuote(undeclared), collapse = ", ")), 4448 domain = NA) 4449 } 4450 4451 mind_suspects <- 4452 config_val_to_logical(Sys.getenv("_R_CHECK_XREFS_MIND_SUSPECT_ANCHORS_", 4453 "FALSE")) 4454 if(mind_suspects) { 4455 db <- cbind(db, suspect = FALSE) 4456 } 4457 4458 for (pkg in anchors) { 4459 ## we can't do this on the current uninstalled package! 4460 if (missing(package) && pkg == basename(dir)) next 4461 this <- have_anchor & (thispkg %in% pkg) 4462 top <- system.file(package = pkg, lib.loc = lib.loc) 4463 if(nzchar(top)) { 4464 RdDB <- file.path(top, "help", "paths.rds") 4465 nm <- sub("\\.[Rr]d", "", basename(readRDS(RdDB))) 4466 good <- thisfile[this] %in% nm 4467 suspect <- if(any(!good)) { 4468 aliases1 <- if (pkg %in% names(aliases)) aliases[[pkg]] 4469 else Rd_aliases(pkg, lib.loc = lib.loc) 4470 !good & (thisfile[this] %in% aliases1) 4471 } else FALSE 4472 db[this, "bad"] <- !good & !suspect 4473 if(mind_suspects) 4474 db[this, "suspect"] <- suspect 4475 4476 } else if(use_aliases_from_CRAN) { 4477 if(is.null(aliases_db)) { 4478 ## Not yet read in. 4479 aliases_db <- CRAN_aliases_db() 4480 } 4481 aliases <- aliases_db[[pkg]] 4482 if(is.null(aliases)) { 4483 unknown <- c(unknown, pkg) 4484 next 4485 } 4486 ## message(sprintf("Using aliases db for package %s", pkg)) 4487 nm <- sub("\\.[Rr]d", "", basename(names(aliases))) 4488 good <- thisfile[this] %in% nm 4489 suspect <- if(any(!good)) { 4490 aliases1 <- unique(as.character(unlist(aliases, 4491 use.names = 4492 FALSE))) 4493 !good & (thisfile[this] %in% aliases1) 4494 } else FALSE 4495 db[this, "bad"] <- !good & !suspect 4496 if(mind_suspects) 4497 db[this, "suspect"] <- suspect 4498 } 4499 else 4500 unknown <- c(unknown, pkg) 4501 } 4502 4503 unknown <- unique(unknown) 4504 if (length(unknown)) { 4505 repos <- .get_standard_repository_URLs() 4506 ## Also allow for additionally specified repositories. 4507 aurls <- pkgInfo[["DESCRIPTION"]]["Additional_repositories"] 4508 if(!is.na(aurls)) { 4509 repos <- c(repos, .read_additional_repositories_field(aurls)) 4510 } 4511 known <- 4512 try(suppressWarnings(utils::available.packages(utils::contrib.url(repos, "source"), 4513 filters = c("R_version", "duplicates"))[, "Package"])) 4514 miss <- if(inherits(known, "try-error")) TRUE 4515 else unknown %in% c(known, c("GLMMGibbs", "survnnet", "yags")) 4516 ## from CRANextras 4517 if(any(miss)) 4518 message(sprintf(ngettext(sum(miss), 4519 "Package unavailable to check Rd xrefs: %s", 4520 "Packages unavailable to check Rd xrefs: %s"), 4521 paste(sQuote(unknown[miss]), collapse = ", ")), 4522 domain = NA) 4523 if(any(!miss)) 4524 message(sprintf(ngettext(sum(!miss), 4525 "Unknown package %s in Rd xrefs", 4526 "Unknown packages %s in Rd xrefs"), 4527 paste(sQuote(unknown[!miss]), collapse = ", ")), 4528 domain = NA) 4529 } 4530 ## The bad ones: 4531 bad <- db[, "bad"] == "TRUE" 4532 out <- list(bad = split(db[bad, "report"], db[bad, "File"])) 4533 if(mind_suspects && any(ind <- db[, "suspect"] == "TRUE")) { 4534 out <- c(out, list(suspect = split(db[ind, "report"], 4535 db[ind, "File"]))) 4536 } 4537 structure(out, class = "check_Rd_xrefs") 4538} 4539 4540format.check_Rd_xrefs <- 4541function(x, ...) 4542{ 4543 xb <- x$bad 4544 xs <- x$suspect 4545 if(length(xb) || length(xs)) { 4546 .fmtb <- function(i) { 4547 c(gettextf("Missing link or links in documentation object '%s':", 4548 names(xb)[i]), 4549 ## NB, link might be empty, and was in mvbutils 4550 .pretty_format(unique(xb[[i]])), 4551 "") 4552 } 4553 .fmts <- function(i) { 4554 c(gettextf("Non-file package-anchored link(s) in documentation object '%s':", 4555 names(xs)[i]), 4556 .pretty_format(unique(xs[[i]])), 4557 "") 4558 } 4559 c(unlist(lapply(seq_along(xb), .fmtb)), 4560 unlist(lapply(seq_along(xs), .fmts)), 4561 strwrap(gettextf("See section 'Cross-references' in the 'Writing R Extensions' manual.")) 4562 ) 4563 } else { 4564 character() 4565 } 4566} 4567 4568### * .check_package_datasets 4569 4570.check_package_datasets <- 4571function(pkgDir) 4572{ 4573 oLC_ct <- Sys.getlocale("LC_CTYPE"); on.exit(Sys.setlocale("LC_CTYPE", oLC_ct)) 4574 Sys.setlocale("LC_CTYPE", "C") 4575 oop <- options(warn = -1) 4576 on.exit(options(oop), add = TRUE) 4577 check_one <- function(x, ds) 4578 { 4579 if(!length(x)) return() 4580 ## avoid as.list methods 4581 if(is.list(x)) lapply(unclass(x), check_one, ds = ds) 4582 if(is.character(x)) { 4583 xx <- unclass(x) 4584 enc <- Encoding(xx) 4585 latin1 <<- latin1 + sum(enc == "latin1") 4586 utf8 <<- utf8 + sum(enc == "UTF-8") 4587 bytes <<- bytes + sum(enc == "bytes") 4588 unk <- xx[enc == "unknown"] 4589 ind <- .Call(C_check_nonASCII2, unk) 4590 if(length(ind)) { 4591 non_ASCII <<- c(non_ASCII, unk[ind]) 4592 where <<- c(where, rep.int(ds, length(ind))) 4593 } 4594 } 4595 a <- attributes(x) 4596 if(!is.null(a)) { 4597 lapply(a, check_one, ds = ds) 4598 check_one(names(a), ds) 4599 } 4600 invisible() 4601 } 4602 4603 sink(tempfile()) ## suppress startup messages to stdout 4604 on.exit(sink(), add = TRUE) 4605 files <- list_files_with_type(file.path(pkgDir, "data"), "data") 4606 files <- unique(basename(file_path_sans_ext(files))) 4607 ans <- vector("list", length(files)) 4608 dataEnv <- new.env(hash=TRUE) 4609 names(ans) <- files 4610 old <- setwd(pkgDir) 4611 4612 ## formerly used .try_quietly which stops on error 4613 .try <- function (expr, msg) { 4614 oop <- options(warn = 1) 4615 on.exit(options(oop)) 4616 outConn <- file(open = "w+") 4617 sink(outConn, type = "output") 4618 sink(outConn, type = "message") 4619 tryCatch(withRestarts(withCallingHandlers(expr, error = { 4620 function(e) invokeRestart("grmbl", e, sys.calls()) 4621 }), grmbl = function(e, calls) { 4622 n <- length(sys.calls()) 4623 calls <- calls[-seq.int(length.out = n - 1L)] 4624 calls <- rev(calls)[-c(1L, 2L)] 4625 tb <- lapply(calls, deparse) 4626 message(msg, conditionMessage(e), "\nCall sequence:\n", 4627 paste(c(utils::head(.eval_with_capture(traceback(tb))$output, 5), 4628 " ..."), 4629 collapse = "\n"), 4630 "\n") 4631 }), error = identity, finally = { 4632 sink(type = "message") 4633 sink(type = "output") 4634 close(outConn) 4635 }) 4636 } 4637 4638 for(f in files) { 4639 msg <- sprintf("Error loading dataset %s: ", sQuote(f)) 4640 .try(utils::data(list = f, package = character(), envir = dataEnv), msg) 4641 } 4642 setwd(old) 4643 4644 non_ASCII <- where <- character() 4645 latin1 <- utf8 <- bytes <- 0L 4646 ## avoid messages about loading packages that started with r48409 4647 ## (and some more ...) 4648 ## add try() to ensure that all datasets are looked at 4649 ## (if not all of each dataset). 4650 for(ds in ls(envir = dataEnv, all.names = TRUE)) { 4651 if(inherits(suppressWarnings(suppressMessages(try(check_one(get(ds, envir = dataEnv), ds), silent = TRUE))), 4652 "try-error")) { 4653 msg <- sprintf("Error loading dataset %s:\n ", sQuote(ds)) 4654 message(msg, geterrmessage()) 4655 } 4656 } 4657 unknown <- unique(cbind(non_ASCII, where)) 4658 structure(list(latin1 = latin1, utf8 = utf8, bytes = bytes, 4659 unknown = unknown), 4660 class = "check_package_datasets") 4661} 4662 4663format.check_package_datasets <- 4664function(x, ...) 4665{ 4666 ## not sQuote as we have mucked about with locales. 4667 iconv0 <- function(x, ...) paste0("'", iconv(x, ...), "'") 4668 4669 suppress_notes <- 4670 config_val_to_logical(Sys.getenv("_R_CHECK_PACKAGE_DATASETS_SUPPRESS_NOTES_", 4671 "FALSE")) 4672 4673 c(character(), 4674 if((n <- x$latin1) && !suppress_notes) { 4675 sprintf( 4676 ngettext(n, 4677 "Note: found %d marked Latin-1 string", 4678 "Note: found %d marked Latin-1 strings"), n) 4679 }, 4680 if((n <- x$utf8) && !suppress_notes) { 4681 sprintf( 4682 ngettext(n, 4683 "Note: found %d marked UTF-8 string", 4684 "Note: found %d marked UTF-8 strings"), n) 4685 }, 4686 if((n <- x$bytes) && !suppress_notes) { 4687 sprintf( 4688 ngettext(n, 4689 "Note: found %d string marked as \"bytes\"", 4690 "Note: found %d strings marked as \"bytes\""), n) 4691 }, 4692 if(nr <- nrow(x$unknown)) { 4693 msg <- ngettext(nr, 4694 "Warning: found non-ASCII string", 4695 "Warning: found non-ASCII strings", 4696 domain = NA) 4697 c(msg, 4698 paste0(iconv0(x$unknown[, 1L], "", "ASCII", sub = "byte"), 4699 " in object '", x$unknown[, 2L], "'")) 4700 }) 4701} 4702 4703### * .check_package_datasets2 4704 4705.check_package_datasets2 <- 4706function(fileName, pkgname) 4707{ 4708 oldSearch <- search() 4709 dataEnv <- new.env(hash = TRUE) 4710 suppressMessages(utils::data(list = fileName, package = pkgname, 4711 envir = dataEnv)) 4712 if (!length((ls(dataEnv)))) message("No dataset created in 'envir'") 4713 if (!identical(search(), oldSearch)) message("Search path was changed") 4714 invisible(NULL) 4715} 4716 4717### * .check_package_compact_datasets 4718 4719.check_package_compact_datasets <- 4720function(pkgDir, thorough = FALSE) 4721{ 4722 msg <- NULL 4723 rdas <- checkRdaFiles(file.path(pkgDir, "data")) 4724 row.names(rdas) <- basename(row.names(rdas)) 4725 problems <- with(rdas, (ASCII | compress == "none") & (size > 1e5)) 4726 if (any(rdas$compress %in% c("bzip2", "xz"))) { 4727 OK <- FALSE 4728 Rdeps <- .split_description(.read_description(file.path(pkgDir, "DESCRIPTION")))$Rdepends2 4729 for(dep in Rdeps) { 4730 if(dep$op != '>=') next 4731 if(dep$version >= package_version("2.10")) {OK <- TRUE; break;} 4732 } 4733 if(!OK) msg <- "Warning: package needs dependence on R (>= 2.10)" 4734 } 4735 if (sum(rdas$size) < 1e5 || # we don't report unless we get a 1e5 reduction 4736 any(rdas$compress %in% c("bzip2", "xz"))) # assume already optimized 4737 thorough <- FALSE 4738 sizes <- improve <- NULL 4739 if (thorough) { 4740 files <- Sys.glob(c(file.path(pkgDir, "data", "*.rda"), 4741 file.path(pkgDir, "data", "*.RData"))) 4742 ## Exclude .RData, which this may or may not match 4743 files <- files[!endsWith(files, "/.RData")] 4744 if (length(files)) { 4745 cpdir <- tempfile('cp') 4746 dir.create(cpdir) 4747 file.copy(files, cpdir) 4748 resaveRdaFiles(cpdir) 4749 rdas2 <- checkRdaFiles(cpdir) 4750 row.names(rdas2) <- basename(row.names(rdas2)) 4751 diff2 <- (rdas2$ASCII != rdas$ASCII) | (rdas2$compress != rdas$compress) 4752 diff2 <- diff2 & (rdas$size > 1e4) & (rdas2$size < 0.9*rdas$size) 4753 sizes <- c(sum(rdas$size), sum(rdas2$size)) 4754 improve <- data.frame(old_size = rdas$size, 4755 new_size = rdas2$size, 4756 compress = rdas2$compress, 4757 row.names = row.names(rdas))[diff2, ] 4758 } 4759 } 4760 structure(list(rdas = rdas[problems, 1:3], msg = msg, 4761 sizes = sizes, improve = improve), 4762 class = "check_package_compact_datasets") 4763} 4764 4765print.check_package_compact_datasets <- 4766function(x, ...) 4767{ 4768 reformat <- function(x) { 4769 xx <- paste0(x, "b") 4770 ind1 <- (x >= 1024) 4771 xx[ind1] <- sprintf("%.0fKb", x[ind1]/1024) 4772 ind2 <- x >= 1024^2 4773 xx[ind2] <- sprintf("%.1fMb", x[ind2]/(1024^2)) 4774 ind3 <- x >= 1024^3 4775 xx[ind3] <- sprintf("%.1fGb", x[ind3]/1024^3) 4776 xx 4777 } 4778 if(nr <- nrow(x$rdas)) { 4779 msg <- ngettext(nr, 4780 "Warning: large data file saved inefficiently:", 4781 "Warning: large data files saved inefficiently:", 4782 domain = NA) 4783 writeLines(msg) 4784 rdas <- x$rdas 4785 rdas$size <- reformat(rdas$size) 4786 print(rdas) 4787 } 4788 if(!is.null(x$msg)) writeLines(x$msg) 4789 if(!is.null(s <- x$sizes) && s[1L] - s[2L] > 1e5 # save at least 100Kb 4790 && s[2L]/s[1L] < 0.9) { # and at least 10% 4791 writeLines(c("", 4792 "Note: significantly better compression could be obtained", 4793 " by using R CMD build --resave-data")) 4794 if(nrow(x$improve)) { 4795 improve <- x$improve 4796 improve$old_size <- reformat(improve$old_size) 4797 improve$new_size <- reformat(improve$new_size) 4798 print(improve) 4799 } 4800 } 4801 invisible(x) 4802} 4803 4804### * .check_package_compact_sysdata 4805 4806.check_package_compact_sysdata <- 4807function(pkgDir, thorough = FALSE) 4808{ 4809 msg <- NULL 4810 files <- file.path(pkgDir, "R", "sysdata.rda") 4811 rdas <- checkRdaFiles(files) 4812 row.names(rdas) <- basename(row.names(rdas)) 4813 problems <- with(rdas, (ASCII | compress == "none") & (size > 1e5)) 4814 if (any(rdas$compress %in% c("bzip2", "xz"))) { 4815 OK <- FALSE 4816 Rdeps <- .split_description(.read_description(file.path(pkgDir, "DESCRIPTION")))$Rdepends2 4817 for(dep in Rdeps) { 4818 if(dep$op != '>=') next 4819 if(dep$version >= package_version("2.10")) {OK <- TRUE; break;} 4820 } 4821 if(!OK) msg <- "Warning: package needs dependence on R (>= 2.10)" 4822 } 4823 if (sum(rdas$size) < 1e5 || # we don't report unless we get a 1e5 reduction 4824 any(rdas$compress %in% c("bzip2", "xz"))) # assume already optimized 4825 thorough <- FALSE 4826 if (thorough) { 4827 cpdir <- tempfile('cp') 4828 dir.create(cpdir) 4829 file.copy(files, cpdir) 4830 resaveRdaFiles(cpdir) 4831 rdas2 <- checkRdaFiles(cpdir) 4832 row.names(rdas2) <- basename(row.names(rdas2)) 4833 diff2 <- (rdas2$ASCII != rdas$ASCII) | (rdas2$compress != rdas$compress) 4834 diff2 <- diff2 & (rdas$size > 1e4) & (rdas2$size < 0.9*rdas$size) 4835 sizes <- c(sum(rdas$size), sum(rdas2$size)) 4836 improve <- data.frame(old_size = rdas$size, 4837 new_size = rdas2$size, 4838 compress = rdas2$compress, 4839 row.names = row.names(rdas))[diff2, ] 4840 } else sizes <- improve <- NULL 4841 structure(list(rdas = rdas[problems, 1:3], msg = msg, 4842 sizes = sizes, improve = improve), 4843 class = "check_package_compact_datasets") 4844} 4845 4846 4847### * .check_package_subdirs 4848 4849## used by R CMD build 4850.check_package_subdirs <- 4851function(dir, doDelete = FALSE) 4852{ 4853 OS_subdirs <- c("unix", "windows") 4854 4855 mydir <- function(dir) 4856 { 4857 d <- list.files(dir, all.files = TRUE, full.names = FALSE) 4858 if(!length(d)) return(d) 4859 if(basename(dir) %in% c("R", "man")) 4860 for(os in OS_subdirs) { 4861 os_dir <- file.path(dir, os) 4862 if(dir.exists(os_dir)) 4863 d <- c(d, 4864 file.path(os, 4865 list.files(os_dir, 4866 all.files = TRUE, 4867 full.names = FALSE))) 4868 } 4869 d[file_test("-f", file.path(dir, d))] 4870 } 4871 4872 if(!dir.exists(dir)) 4873 stop(gettextf("directory '%s' does not exist", dir), domain = NA) 4874 else 4875 dir <- file_path_as_absolute(dir) 4876 4877 wrong_things <- list(R = character(), man = character(), 4878 demo = character(), `inst/doc` = character()) 4879 4880 code_dir <- file.path(dir, "R") 4881 if(dir.exists(code_dir)) { 4882 all_files <- mydir(code_dir) 4883 ## Under Windows, need a Makefile.win for methods. 4884 R_files <- c("sysdata.rda", "Makefile.win", 4885 list_files_with_type(code_dir, "code", 4886 full.names = FALSE, 4887 OS_subdirs = OS_subdirs)) 4888 wrong <- setdiff(all_files, R_files) 4889 ## now configure might generate files in this directory 4890 generated <- which(endsWith(wrong, ".in")) 4891 if(length(generated)) wrong <- wrong[-generated] 4892 if(length(wrong)) { 4893 wrong_things$R <- wrong 4894 if(doDelete) unlink(file.path(dir, "R", wrong)) 4895 } 4896 } 4897 4898 man_dir <- file.path(dir, "man") 4899 if(dir.exists(man_dir)) { 4900 all_files <- mydir(man_dir) 4901 man_files <- list_files_with_type(man_dir, "docs", 4902 full.names = FALSE, 4903 OS_subdirs = OS_subdirs) 4904 wrong <- setdiff(all_files, man_files) 4905 if(length(wrong)) { 4906 wrong_things$man <- wrong 4907 if(doDelete) unlink(file.path(dir, "man", wrong)) 4908 } 4909 } 4910 4911 demo_dir <- file.path(dir, "demo") 4912 if(dir.exists(demo_dir)) { 4913 all_files <- mydir(demo_dir) 4914 demo_files <- list_files_with_type(demo_dir, "demo", 4915 full.names = FALSE) 4916 wrong <- setdiff(all_files, c("00Index", demo_files)) 4917 if(length(wrong)) { 4918 wrong_things$demo <- wrong 4919 if(doDelete) unlink(file.path(dir, "demo", wrong)) 4920 } 4921 } 4922 4923 ## check installed vignette material 4924 subdir <- file.path("inst", "doc") 4925 vigns <- pkgVignettes(dir = dir, subdirs = subdir) 4926 if (!is.null(vigns) && length(vigns$docs)) { 4927 vignettes <- basename(vigns$docs) 4928 4929 ## Add vignette output files, if they exist 4930 tryCatch({ 4931 vigns <- pkgVignettes(dir = dir, subdirs = subdir, output = TRUE) 4932 vignettes <- c(vignettes, basename(vigns$outputs)) 4933 }, error = function(ex) {}) 4934 4935 ## 'the file names should start with an ASCII letter and be comprised 4936 ## entirely of ASCII letters or digits or hyphen or underscore' 4937 ## Do this in a locale-independent way. 4938 OK <- grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz][ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789._-]+$", vignettes) 4939 wrong <- vignettes 4940 if(length(OK)) wrong <- wrong[-OK] 4941 if(length(wrong)) wrong_things$`inst/doc` <- wrong 4942 } 4943 4944 class(wrong_things) <- "subdir_tests" 4945 wrong_things 4946} 4947 4948format.subdir_tests <- 4949function(x, ...) 4950{ 4951 .fmt <- function(i) { 4952 tag <- names(x)[i] 4953 c(sprintf("Subdirectory '%s' contains invalid file names:", 4954 tag), 4955 .pretty_format(x[[i]])) 4956 } 4957 4958 as.character(unlist(lapply(which(lengths(x) > 0L), .fmt))) 4959} 4960 4961### * .check_package_ASCII_code 4962 4963.check_package_ASCII_code <- 4964function(dir, respect_quotes = FALSE) 4965{ 4966 OS_subdirs <- c("unix", "windows") 4967 if(!dir.exists(dir)) 4968 stop(gettextf("directory '%s' does not exist", dir), domain = NA) 4969 else 4970 dir <- file_path_as_absolute(dir) 4971 4972 code_dir <- file.path(dir, "R") 4973 wrong_things <- character() 4974 if(dir.exists(code_dir)) { 4975 R_files <- list_files_with_type(code_dir, "code", 4976 full.names = FALSE, 4977 OS_subdirs = OS_subdirs) 4978 for(f in R_files) { 4979 text <- readLines(file.path(code_dir, f), warn = FALSE) 4980 if(.Call(C_check_nonASCII, text, !respect_quotes)) 4981 wrong_things <- c(wrong_things, f) 4982 } 4983 } 4984 if(length(wrong_things)) cat(wrong_things, sep = "\n") 4985 invisible(wrong_things) 4986} 4987 4988### * .check_package_code_syntax 4989 4990.check_package_code_syntax <- 4991function(dir) 4992{ 4993 if(!dir.exists(dir)) 4994 stop(gettextf("directory '%s' does not exist", dir), domain = NA) 4995 else 4996 dir <- file_path_as_absolute(dir) 4997 dir_name <- basename(dir) 4998 4999 dfile <- file.path(dirname(dir), "DESCRIPTION") 5000 enc <- if(file.exists(dfile)) 5001 .read_description(dfile)["Encoding"] else NA 5002 5003 ## This was always run in the C locale < 2.5.0 5004 ## However, what chars are alphabetic depends on the locale, 5005 ## so as from R 2.5.0 we try to set a locale. 5006 ## Any package with no declared encoding should have only ASCII R 5007 ## code. 5008 oLC_ct <- Sys.getlocale("LC_CTYPE"); on.exit(Sys.setlocale("LC_CTYPE", oLC_ct)) 5009 if(!is.na(enc)) { ## try to use the declared encoding 5010 if(.Platform$OS.type == "windows") { 5011 ## "C" is in fact "en", and there are no UTF-8 locales 5012 switch(enc, 5013 "latin2" = Sys.setlocale("LC_CTYPE", 'polish'), 5014 Sys.setlocale("LC_CTYPE", "C") 5015 ) 5016 } else { 5017 loc <- Sys.getenv("R_ENCODING_LOCALES", NA_character_) 5018 if(!is.na(loc)) { 5019 loc <- strsplit(strsplit(loc, ":")[[1L]], "=") 5020 nm <- lapply(loc, "[[", 1L) 5021 loc <- lapply(loc, "[[", 2L) 5022 names(loc) <- nm 5023 if(!is.null(l <- loc[[enc]])) 5024 Sys.setlocale("LC_CTYPE", l) 5025 else 5026 Sys.setlocale("LC_CTYPE", "C") 5027 5028 } else if(l10n_info()[["UTF-8"]]) { 5029 ## the hope is that the conversion to UTF-8 works and 5030 ## so we can validly test the code in the current locale. 5031 } else { 5032 ## these are the POSIX forms, but of course not all Unixen 5033 ## abide by POSIX. These locales need not exist, but 5034 ## do in glibc. 5035 switch(enc, 5036 "latin1" = Sys.setlocale("LC_CTYPE", "en_US"), 5037 "utf-8" =, # not valid, but used 5038 "UTF-8" = Sys.setlocale("LC_CTYPE", "en_US.UTF-8"), 5039 "latin2" = Sys.setlocale("LC_CTYPE", "pl_PL"), 5040 "latin9" = Sys.setlocale("LC_CTYPE", 5041 "fr_FR.iso885915@euro"), 5042 Sys.setlocale("LC_CTYPE", "C") 5043 ) 5044 } 5045 } 5046 } 5047 5048 collect_parse_woes <- function(f) { 5049 .error <- .warnings <- character() 5050 file <- file.path(dir, f) 5051 if(!is.na(enc) && 5052 (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { 5053 lines <- iconv(readLines(file, warn = FALSE), from = enc, to = "", 5054 sub = "byte") 5055 withCallingHandlers(tryCatch(str2expression(lines), 5056 error = function(e) 5057 .error <<- conditionMessage(e)), 5058 warning = function(e) { 5059 .warnings <<- c(.warnings, 5060 conditionMessage(e)) 5061 tryInvokeRestart("muffleWarning") 5062 }) 5063 } else { 5064 withCallingHandlers(tryCatch(parse(file), 5065 error = function(e) 5066 .error <<- conditionMessage(e)), 5067 warning = function(e) { 5068 .warnings <<- c(.warnings, 5069 conditionMessage(e)) 5070 tryInvokeRestart("muffleWarning") 5071 }) 5072 } 5073 ## (We show offending file paths starting with the base of the 5074 ## given directory as this provides "nicer" output ...) 5075 if(length(.error) || length(.warnings)) 5076 list(File = file.path(dir_name, f), 5077 Error = .error, Warnings = .warnings) 5078 else 5079 NULL 5080 } 5081 5082 out <- 5083 lapply(list_files_with_type(dir, "code", full.names = FALSE, 5084 OS_subdirs = c("unix", "windows")), 5085 collect_parse_woes) 5086 structure(out[lengths(out) > 0L], 5087 class = "check_package_code_syntax") 5088} 5089 5090print.check_package_code_syntax <- 5091function(x, ...) 5092{ 5093 first <- TRUE 5094 for(i in seq_along(x)) { 5095 if(!first) writeLines("") else first <- FALSE 5096 xi <- x[[i]] 5097 if(length(xi$Error)) { 5098 msg <- gsub("\n", "\n ", sub("[^:]*: *", "", xi$Error), 5099 perl = TRUE, useBytes = TRUE) 5100 writeLines(c(sprintf("Error in file '%s':", xi$File), 5101 paste0(" ", msg))) 5102 } 5103 if(len <- length(xi$Warnings)) 5104 writeLines(c(sprintf(ngettext(len, 5105 "Warning in file %s:", 5106 "Warnings in file %s:"), 5107 sQuote(xi$File)), 5108 paste0(" ", gsub("\n\n", "\n ", xi$Warnings, 5109 perl = TRUE, useBytes = TRUE)))) 5110 } 5111 invisible(x) 5112} 5113 5114### * .check_package_code_shlib 5115 5116.check_package_code_shlib <- 5117function(dir) 5118{ 5119 predicate <- function(e) { 5120 ((length(e) > 1L) 5121 && (length(x <- as.character(e[[1L]])) == 1L) 5122 && (x %in% c("library.dynam", "library.dynam.unload")) 5123 && (length(y <- e[[2L]]) == 1L) 5124 && is.character(y) 5125 && grepl("\\.(so|sl|dll)$", y)) 5126 } 5127 5128 x <- Filter(length, 5129 .find_calls_in_package_code(dir, predicate, 5130 recursive = TRUE)) 5131 5132 ## Because we really only need this for calling from R CMD check, we 5133 ## produce output here in case we found something. 5134 if(length(x)) 5135 writeLines(c(unlist(Map(.format_calls_in_file, x, names(x))), 5136 "")) 5137 ## (Could easily provide format() and print() methods ...) 5138 5139 invisible(x) 5140} 5141 5142### * .check_package_code_startup_functions 5143 5144.check_package_code_startup_functions <- 5145function(dir) 5146{ 5147 bad_call_names <- 5148 unlist(.bad_call_names_in_startup_functions) 5149 5150 .check_startup_function <- function(fcode, fname) { 5151 out <- list() 5152 nms <- names(fcode[[2L]]) 5153 ## Check names of formals. 5154 ## Allow anything containing ... (for now); otherwise, insist on 5155 ## length two with names starting with lib and pkg, respectively. 5156 if(("..." %notin% nms) && 5157 ((length(nms) != 2L) || 5158 any(substr(nms, 1L, 3L) != c("lib", "pkg")))) 5159 out$bad_arg_names <- nms 5160 ## Look at all calls (not only at top level). 5161 calls <- .find_calls(fcode[[3L]], recursive = TRUE) 5162 if(!length(calls)) return(out) 5163 cnames <- .call_names(calls) 5164 ## And pick the ones which should not be there ... 5165 bcn <- bad_call_names 5166 if(fname == ".onAttach") bcn <- c(bcn, "library.dynam") 5167 if(fname == ".onLoad") bcn <- c(bcn, "packageStartupMessage") 5168 ind <- (cnames %in% bcn) 5169 if(any(ind)) { 5170 calls <- calls[ind] 5171 cnames <- cnames[ind] 5172 ## Exclude library(help = ......) calls. 5173 pos <- which(cnames == "library") 5174 if(length(pos)) { 5175 pos <- pos[vapply(calls[pos], 5176 function(e) 5177 any(names(e)[-1L] == "help"), 5178 NA)] 5179 ## Could also match.call(base::library, e) first ... 5180 if(length(pos)) { 5181 calls <- calls[-pos] 5182 cnames <- cnames[-pos] 5183 } 5184 } 5185 if(length(calls)) { 5186 out$bad_calls <- 5187 list(calls = calls, names = cnames) 5188 } 5189 } 5190 out 5191 } 5192 5193 calls <- .find_calls_in_package_code(dir, 5194 .worker = 5195 .get_startup_function_calls_in_file) 5196 FL <- unlist(lapply(calls, "[[", ".First.lib")) 5197 calls <- Filter(length, 5198 lapply(calls, 5199 function(e) 5200 Filter(length, 5201 Map(.check_startup_function, 5202 e, names(e))))) 5203 if(length(FL)) attr(calls, ".First.lib") <- TRUE 5204 class(calls) <- "check_package_code_startup_functions" 5205 calls 5206} 5207 5208format.check_package_code_startup_functions <- 5209function(x, ...) 5210{ 5211 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() 5212 if(length(x)) { 5213 5214 ## Flatten out doubly recursive list of functions within list of 5215 ## files structure for computing summary messages. 5216 y <- unlist(x, recursive = FALSE) 5217 5218 has_bad_wrong_args <- 5219 "bad_arg_names" %in% unlist(lapply(y, names)) 5220 calls <- 5221 unique(unlist(lapply(y, 5222 function(e) e[["bad_calls"]][["names"]]))) 5223 has_bad_calls_for_load <- 5224 any(calls %in% .bad_call_names_in_startup_functions$load) 5225 has_bad_calls_for_output <- 5226 any(calls %in% .bad_call_names_in_startup_functions$output) 5227 has_unsafe_calls <- 5228 any(calls %in% .bad_call_names_in_startup_functions$unsafe) 5229 5230 .fmt_entries_for_file <- function(e, f) { 5231 c(gettextf("File %s:", sQuote(f)), 5232 unlist(Map(.fmt_entries_for_function, e, names(e))), 5233 "") 5234 } 5235 5236 .fmt_entries_for_function <- function(e, f) { 5237 c(if(length(bad <- e[["bad_arg_names"]])) { 5238 gettextf(" %s has wrong argument list %s", 5239 f, sQuote(paste(bad, collapse = ", "))) 5240 }, 5241 if(length(bad <- e[["bad_calls"]])) { 5242 c(gettextf(" %s calls:", f), 5243 paste0(" ", 5244 unlist(lapply(bad[["calls"]], function(e) 5245 paste(deparse(e), collapse = ""))))) 5246 }) 5247 } 5248 5249 res <- 5250 c(res, 5251 unlist(Map(.fmt_entries_for_file, x, names(x)), 5252 use.names = FALSE), 5253 if(has_bad_wrong_args) 5254 strwrap(gettextf("Package startup functions should have two arguments with names starting with %s and %s, respectively.", 5255 sQuote("lib"), sQuote("pkg")), 5256 exdent = 2L), 5257 if(has_bad_calls_for_load) 5258 strwrap(gettextf("Package startup functions should not change the search path."), 5259 exdent = 2L), 5260 if(has_bad_calls_for_output) 5261 strwrap(gettextf("Package startup functions should use %s to generate messages.", 5262 sQuote("packageStartupMessage")), 5263 exdent = 2L), 5264 if(has_unsafe_calls) 5265 strwrap(gettextf("Package startup functions should not call %s.", 5266 sQuote("installed.packages")), 5267 exdent = 2L), 5268 gettextf("See section %s in '%s'.", 5269 sQuote("Good practice"), "?.onAttach") 5270 ) 5271 } 5272 res 5273} 5274 5275.bad_call_names_in_startup_functions <- 5276 list(load = c("library", "require"), 5277 output = c("cat", "message", "print", "writeLines"), 5278 unsafe = c("installed.packages", "utils::installed.packages")) 5279 5280.get_startup_function_calls_in_file <- 5281function(file, encoding = NA) 5282{ 5283 exprs <- .parse_code_file(file, encoding) 5284 5285 ## Use a custom gatherer rather than .find_calls() with a suitable 5286 ## predicate so that we record the name of the startup function in 5287 ## which the calls were found. 5288 calls <- list() 5289 for(e in exprs) { 5290 if((length(e) > 2L) && 5291 (is.name(x <- e[[1L]])) && 5292 (as.character(x) %in% c("<-", "=")) && 5293 (length(y <- as.character(e[[2L]])) == 1L) && 5294 (y %in% c(".First.lib", ".onAttach", ".onLoad")) && 5295 (is.call(z <- e[[3L]])) && 5296 (as.character(z[[1L]]) == "function")) { 5297 new <- list(z) 5298 names(new) <- as.character(y) 5299 calls <- c(calls, new) 5300 } 5301 } 5302 calls 5303} 5304 5305.call_names <- 5306function(x) 5307 as.character(sapply(x, function(e) deparse(e[[1L]]))) 5308 5309 5310### * .check_package_code_unload_functions 5311 5312.check_package_code_unload_functions <- 5313function(dir) 5314{ 5315 bad_call_names <- "library.dynam.unload" 5316 5317 .check_unload_function <- function(fcode, fname) { 5318 out <- list() 5319 nms <- names(fcode[[2L]]) 5320 ## Check names of formals. 5321 ## Allow anything containing ... (for now); otherwise, insist on 5322 ## length one with names starting with lib. 5323 if("..." %notin% nms && (length(nms) != 1L || !startsWith(nms, "lib"))) 5324 out$bad_arg_names <- nms 5325 ## Look at all calls (not only at top level). 5326 calls <- .find_calls(fcode[[3L]], recursive = TRUE) 5327 if(!length(calls)) return(out) 5328 cnames <- .call_names(calls) 5329 ## And pick the ones which should not be there ... 5330 ind <- cnames %in% bad_call_names 5331 if(any(ind)) 5332 out$bad_calls <- list(calls = calls[ind], names = cnames[ind]) 5333 out 5334 } 5335 5336 calls <- .find_calls_in_package_code(dir, 5337 .worker = 5338 .get_unload_function_calls_in_file) 5339 LL <- unlist(lapply(calls, "[[", ".Last.lib")) 5340 calls <- Filter(length, 5341 lapply(calls, 5342 function(e) 5343 Filter(length, 5344 Map(.check_unload_function, 5345 e, names(e))))) 5346 if(length(LL)) { 5347 code_objs <- ".Last.lib" 5348 nsInfo <- parseNamespaceFile(basename(dir), dirname(dir)) 5349 OK <- intersect(code_objs, nsInfo$exports) 5350 for(p in nsInfo$exportPatterns) 5351 OK <- c(OK, grep(p, code_objs, value = TRUE)) 5352 if(!length(OK)) attr(calls, ".Last.lib") <- TRUE 5353 } 5354 class(calls) <- "check_package_code_unload_functions" 5355 calls 5356} 5357 5358format.check_package_code_unload_functions <- 5359function(x, ...) 5360{ 5361 res <- if(!is.null(attr(x, ".Last.lib"))) "NB: .Last.lib will not be used unless it is exported" else character() 5362 if(length(x)) { 5363 5364 ## Flatten out doubly recursive list of functions within list of 5365 ## files structure for computing summary messages. 5366 y <- unlist(x, recursive = FALSE) 5367 5368 has_bad_wrong_args <- 5369 "bad_arg_names" %in% unlist(lapply(y, names)) 5370## calls <- 5371## unique(unlist(lapply(y, 5372## function(e) e[["bad_calls"]][["names"]]))) 5373 .fmt_entries_for_file <- function(e, f) { 5374 c(gettextf("File %s:", sQuote(f)), 5375 unlist(Map(.fmt_entries_for_function, e, names(e))), 5376 "") 5377 } 5378 5379 .fmt_entries_for_function <- function(e, f) { 5380 c(if(length(bad <- e[["bad_arg_names"]])) { 5381 gettextf(" %s has wrong argument list %s", 5382 f, sQuote(paste(bad, collapse = ", "))) 5383 }, 5384 if(length(bad <- e[["bad_calls"]])) { 5385 c(gettextf(" %s calls:", f), 5386 paste0(" ", 5387 unlist(lapply(bad[["calls"]], function(e) 5388 paste(deparse(e), collapse = ""))))) 5389 }) 5390 } 5391 5392 res <- 5393 c(res, 5394 unlist(Map(.fmt_entries_for_file, x, names(x)), 5395 use.names = FALSE), 5396 if(has_bad_wrong_args) 5397 strwrap(gettextf("Package detach functions should have one argument with name starting with %s.", sQuote("lib")), 5398 exdent = 2L), 5399 if(length(call)) 5400 strwrap(gettextf("Package detach functions should not call %s.", 5401 sQuote("library.dynam.unload")), 5402 exdent = 2L), 5403 gettextf("See section %s in '%s'.", 5404 sQuote("Good practice"), "?.Last.lib") 5405 ) 5406 } 5407 res 5408} 5409 5410.get_unload_function_calls_in_file <- 5411function(file, encoding = NA) 5412{ 5413 exprs <- .parse_code_file(file, encoding) 5414 5415 ## Use a custom gatherer rather than .find_calls() with a suitable 5416 ## predicate so that we record the name of the unload function in 5417 ## which the calls were found. 5418 calls <- list() 5419 for(e in exprs) { 5420 if((length(e) > 2L) && 5421 (is.name(x <- e[[1L]])) && 5422 (as.character(x) %in% c("<-", "=")) && 5423 (length(y <- as.character(e[[2L]])) == 1L) && 5424 (y %in% c(".Last.lib", ".onDetach")) && 5425 (is.call(z <- e[[3L]])) && 5426 (as.character(z[[1L]]) == "function")) { 5427 new <- list(z) 5428 names(new) <- as.character(y) 5429 calls <- c(calls, new) 5430 } 5431 } 5432 calls 5433} 5434 5435### * .check_package_code_tampers 5436 5437.check_package_code_tampers <- 5438function(dir) 5439{ 5440 dfile <- file.path(dir, "DESCRIPTION") 5441 pkgname <- if(file.exists(dfile)) 5442 .read_description(dfile)["Package"] else "" 5443 5444 predicate <- function(e) { 5445 if(length(e) <= 1L) return(FALSE) 5446 if(as.character(e[[1L]])[1L] %in% "unlockBinding") { 5447 e3 <- as.character(e[[3L]]) 5448 if (e3[[1L]] == "asNamespace") e3 <- as.character(e[[3L]][[2L]]) 5449 return(e3 != pkgname) 5450 } 5451 if((as.character(e[[1L]])[1L] %in% ".Internal") && 5452 as.character(e[[2L]][[1L]]) == "unlockBinding") return(TRUE) 5453 if(as.character(e[[1L]])[1L] %in% "assignInNamespace") { 5454 e3 <- as.character(e[[4L]]) 5455 if (e3[[1L]] == "asNamespace") e3 <- as.character(e[[4L]][[2L]]) 5456 return(e3 != pkgname) 5457 } 5458 FALSE 5459 } 5460 5461 x <- Filter(length, 5462 .find_calls_in_package_code(dir, predicate, 5463 recursive = TRUE)) 5464 5465 ## Because we really only need this for calling from R CMD check, we 5466 ## produce output here in case we found something. 5467 if(length(x)) 5468 writeLines(unlist(Map(.format_calls_in_file, x, names(x)))) 5469 ## (Could easily provide format() and print() methods ...) 5470 5471 invisible(x) 5472} 5473 5474### * .check_package_code_assign_to_globalenv 5475 5476.check_package_code_assign_to_globalenv <- 5477function(dir) 5478{ 5479 predicate <- function(e) { 5480 if(!is.call(e) || 5481 (length(x <- as.character(e[[1L]])) != 1L) || 5482 (x != "assign")) 5483 return(FALSE) 5484 e <- e[as.character(e) != "..."] 5485 ## Capture assignments to global env unless to .Random.seed. 5486 ## (This may fail for conditionalized code not meant for R 5487 ## [e.g., argument 'where'].) 5488 mc <- tryCatch(match.call(base::assign, e), error = identity) 5489 if(inherits(mc, "error") || identical(mc$x, ".Random.seed")) 5490 return(FALSE) 5491 if(!is.null(env <- mc$envir) && 5492 identical(tryCatch(eval(env), 5493 error = identity), 5494 globalenv())) 5495 return(TRUE) 5496 if(!is.null(pos <- mc$pos) && 5497 identical(tryCatch(eval(call("as.environment", pos)), 5498 error = identity), 5499 globalenv())) 5500 return(TRUE) 5501 FALSE 5502 } 5503 5504 calls <- Filter(length, 5505 .find_calls_in_package_code(dir, predicate, 5506 recursive = TRUE)) 5507 class(calls) <- "check_package_code_assign_to_globalenv" 5508 calls 5509} 5510 5511format.check_package_code_assign_to_globalenv <- 5512function(x, ...) 5513{ 5514 if(!length(x)) return(character()) 5515 5516 c("Found the following assignments to the global environment:", 5517 unlist(Map(.format_calls_in_file, x, names(x)))) 5518} 5519 5520### * .check_package_code_attach 5521 5522.check_package_code_attach <- 5523function(dir) 5524{ 5525 predicate <- function(e) 5526 ((length(x <- as.character(e[[1L]])) == 1L) && 5527 (x == "attach")) 5528 5529 calls <- Filter(length, 5530 .find_calls_in_package_code(dir, predicate, 5531 recursive = TRUE)) 5532 class(calls) <- "check_package_code_attach" 5533 calls 5534} 5535 5536format.check_package_code_attach <- 5537function(x, ...) 5538{ 5539 if(!length(x)) return(character()) 5540 5541 c("Found the following calls to attach():", 5542 unlist(Map(.format_calls_in_file, x, names(x)))) 5543} 5544 5545### * .check_package_code_data_into_globalenv 5546 5547.check_package_code_data_into_globalenv <- 5548function(dir) 5549{ 5550 predicate <- function(e) { 5551 if(!is.call(e) || 5552 (length(x <- as.character(e[[1L]])) != 1L) || 5553 (x != "data")) 5554 return(FALSE) 5555 ## As data() has usage 5556 ## data(..., list = character(), package = NULL, lib.loc = NULL, 5557 ## verbose = getOption("verbose"), envir = .GlobalEnv)) 5558 ## argument 'envir' must be matched exactly, and calls which 5559 ## only have the last four arguments do not load any data. 5560 env <- e$envir 5561 tab <- c("package", "lib.loc", "verbose", "envir") 5562 if(!is.null(nms <- names(e))) 5563 e <- e[nms %notin% tab] 5564 ((length(e) > 1L) && 5565 (is.null(env) || 5566 (is.name(env) && as.character(env) == ".GlobalEnv") || 5567 (is.call(env) && as.character(env[[1L]]) == "globalenv"))) 5568 } 5569 5570 calls <- Filter(length, 5571 .find_calls_in_package_code(dir, predicate, 5572 recursive = TRUE)) 5573 class(calls) <- "check_package_code_data_into_globalenv" 5574 calls 5575} 5576 5577format.check_package_code_data_into_globalenv <- 5578function(x, ...) 5579{ 5580 if(!length(x)) return(character()) 5581 5582 c("Found the following calls to data() loading into the global environment:", 5583 unlist(Map(.format_calls_in_file, x, names(x)))) 5584} 5585 5586### * .check_packages_used 5587 5588.check_packages_used <- 5589function(package, dir, lib.loc = NULL) 5590{ 5591 ## Argument handling. 5592 ns <- NULL 5593 if(!missing(package)) { 5594 if(length(package) != 1L) 5595 stop("argument 'package' must be of length 1") 5596 dir <- find.package(package, lib.loc) 5597 ## Using package installed in @code{dir} ... 5598 code_dir <- file.path(dir, "R") 5599 if(!dir.exists(code_dir)) 5600 stop(gettextf("directory '%s' does not contain R code", 5601 dir), 5602 domain = NA) 5603 if(basename(dir) != "base") 5604 .load_package_quietly(package, lib.loc) 5605 code_env <- if(packageHasNamespace(package, dirname(dir))) 5606 asNamespace(package) 5607 else 5608 .package_env(package) 5609 dfile <- file.path(dir, "DESCRIPTION") 5610 db <- .read_description(dfile) 5611 ## fake installs do not have this. 5612 nsfile <- file.path(dir, "Meta", "nsInfo.rds") 5613 if (file.exists(nsfile)) ns <- readRDS(nsfile) 5614 else { 5615 nsfile <- file.path(dir, "NAMESPACE") 5616 if(file.exists(nsfile)) 5617 ns <- parseNamespaceFile(basename(dir), dirname(dir)) 5618 } 5619 } 5620 else if(!missing(dir)) { 5621 ## Using sources from directory @code{dir} ... 5622 if(!dir.exists(dir)) 5623 stop(gettextf("directory '%s' does not exist", dir), 5624 domain = NA) 5625 else 5626 dir <- file_path_as_absolute(dir) 5627 dfile <- file.path(dir, "DESCRIPTION") 5628 db <- .read_description(dfile) 5629 nsfile <- file.path(dir, "NAMESPACE") 5630 if(file.exists(nsfile)) 5631 ns <- parseNamespaceFile(basename(dir), dirname(dir)) 5632 code_dir <- file.path(dir, "R") 5633 if(dir.exists(code_dir)) { 5634 file <- tempfile() 5635 on.exit(unlink(file)) 5636 if(!file.create(file)) stop("unable to create ", file) 5637 if(!all(.file_append_ensuring_LFs(file, 5638 list_files_with_type(code_dir, 5639 "code")))) 5640 stop("unable to write code files") 5641 } else return(invisible()) 5642 } 5643 pkg_name <- db["Package"] 5644 depends <- .get_requires_from_package_db(db, "Depends") 5645 imports <- imports0 <- .get_requires_from_package_db(db, "Imports") 5646 suggests <- .get_requires_from_package_db(db, "Suggests") 5647 enhances <- .get_requires_from_package_db(db, "Enhances") 5648 5649 ## it is OK to refer to yourself and non-S4 standard packages 5650 standard_package_names <- 5651 setdiff(.get_standard_package_names()$base, 5652 c("methods", "stats4")) 5653 ## It helps to know if non-default standard packages are require()d 5654 ## but safer to list them: compiler & parallel got included for years 5655 ## Some people depend on 'base'! 5656 default_package_names <- 5657 c("base", "datasets", "grDevices", "graphics", "stats", "utils") 5658 depends_suggests <- c(depends, suggests, enhances, pkg_name, default_package_names) 5659 imports <- c(imports, depends, suggests, enhances, pkg_name, 5660 standard_package_names) 5661 ## the first argument could be named, or could be a variable name. 5662 ## we just have a stop list here. 5663 common_names <- c("pkg", "pkgName", "package", "pos", "dep_name") 5664 5665 bad_exprs <- bad_deps <- bad_imps <- bad_prac <- character() 5666 bad_imports <- all_imports <- imp2 <- imp2f <- imp3 <- imp3f <- character() 5667 uses_methods <- FALSE 5668 find_bad_exprs <- function(e) { 5669 if(is.call(e) || is.expression(e)) { 5670 Call <- deparse(e[[1L]])[1L] 5671 if(Call %in% c("clusterEvalQ", "parallel::clusterEvalQ")) return() 5672 if((Call %in% 5673 c("library", "require", "loadNamespace", "requireNamespace")) 5674 && (length(e) >= 2L)) { 5675 ## We need to remove '...': OTOH the argument could be NULL 5676 keep <- vapply(e, function(x) deparse(x)[1L] != "...", NA) 5677 mc <- match.call(baseenv()[[Call]], e[keep]) 5678 if(!is.null(pkg <- mc$package)) { 5679 ## <NOTE> 5680 ## Using code analysis, we really don't know which 5681 ## package was called if character.only = TRUE and 5682 ## the package argument is not a string constant. 5683 ## (BTW, what if character.only is given a value 5684 ## which is an expression evaluating to TRUE?) 5685 dunno <- FALSE 5686 if(isTRUE(mc$character.only) 5687 && !identical(class(pkg), "character")) 5688 dunno <- TRUE 5689 ## </NOTE> 5690 ## <FIXME> could be inside substitute or a variable 5691 ## and is in e.g. R.oo 5692 if(!dunno) { 5693 if (Call %in% c("loadNamespace", "requireNamespace")) { 5694 if (identical(class(pkg), "character")) { 5695 pkg <- sub('^"(.*)"$', '\\1', deparse(pkg)) 5696 if(! pkg %in% 5697 c(imports, depends_suggests, common_names)) 5698 bad_imps <<- c(bad_imps, pkg) 5699 } 5700 } else { 5701 pkg <- sub('^"(.*)"$', '\\1', deparse(pkg)) 5702 if(pkg %notin% c(depends_suggests, common_names)) 5703 bad_exprs <<- c(bad_exprs, pkg) 5704 if(pkg %in% depends) 5705 bad_deps <<- c(bad_deps, pkg) 5706 ## assume calls to itself are to clusterEvalQ etc 5707 else if (pkg != pkg_name) 5708 bad_prac <<- c(bad_prac, pkg) 5709 } 5710 } 5711 } 5712 } else if(Call %in% "::") { 5713 pkg <- deparse(e[[2L]]) 5714 all_imports <<- c(all_imports, pkg) 5715 if(pkg %notin% imports) 5716 bad_imports <<- c(bad_imports, pkg) 5717 else { 5718 imp2 <<- c(imp2, pkg) 5719 imp2f <<- c(imp2f, deparse(e[[3L]])) 5720 } 5721 } else if(Call %in% ":::") { 5722 pkg <- deparse(e[[2L]]) 5723 all_imports <<- c(all_imports, pkg) 5724 imp3 <<- c(imp3, pkg) 5725 imp3f <<- c(imp3f, deparse(e[[3L]])) 5726 if(pkg %notin% imports) 5727 bad_imports <<- c(bad_imports, pkg) 5728 } else if(Call %in% c("setClass", "setMethod")) { 5729 uses_methods <<- TRUE 5730 } else if((Call %in% c("<-", "<<-")) && 5731 is.call(e[[2L]]) && 5732 is.call(e21 <- e[[2L]][[1L]]) && 5733 (deparse(e21[[1L]])[1L] %in% c("::", ":::"))) { 5734 ## For complex assignments like 5735 ## pkg::fun(......) <- rhs 5736 ## need to look for replacement function 'fun<-' in pkg 5737 ## (PR#17613). 5738 e[[2L]][[1L]][[3L]] <- 5739 as.name(paste0(deparse(e21[[3L]])[1L], "<-")) 5740 } 5741 for(i in seq_along(e)) Recall(e[[i]]) 5742 } 5743 } 5744 5745 if(!missing(package)) { 5746 ## <FIXME> 5747 ## Suggested way of checking for S4 metadata. 5748 ## Change to use as envir_has_S4_metadata() once this makes it 5749 ## into base or methods. 5750 if(length(objects(code_env, all.names = TRUE, 5751 pattern = "^[.]__[CT]_"))) 5752 uses_methods <- TRUE 5753 ## </FIXME> 5754 exprs <- lapply(ls(envir = code_env, all.names = TRUE), 5755 function(f) { 5756 f <- get(f, envir = code_env) # get is expensive 5757 if(typeof(f) == "closure") body(f) # else NULL 5758 }) 5759 if(.isMethodsDispatchOn()) { 5760 ## Also check the code in S4 methods. 5761 ## This may find things twice. 5762 for(f in .get_S4_generics(code_env)) { 5763 mlist <- .get_S4_methods_list(f, code_env) 5764 exprs <- c(exprs, lapply(mlist, body)) 5765 } 5766 } 5767 } 5768 else { 5769 enc <- db["Encoding"] 5770 if(!is.na(enc) && 5771 (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { 5772 ## FIXME: what if conversion fails on e.g. UTF-8 comments 5773 con <- file(file, encoding=enc) 5774 on.exit(close(con)) 5775 } else con <- file 5776 exprs <- 5777 tryCatch(parse(file = con, n = -1L), 5778 error = function(e) 5779 stop(gettextf("parse error in file '%s':\n%s", 5780 file, 5781 .massage_file_parse_error_message(conditionMessage(e))), 5782 domain = NA, call. = FALSE)) 5783 } 5784 5785 for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]]) 5786 5787 if(length(ns)) { 5788 imp <- c(ns$imports, ns$importClasses, ns$importMethods) 5789 if (length(imp)) { 5790 imp <- sapply(imp, function(x) x[[1L]]) 5791 all_imports <- unique(c(imp, all_imports)) 5792 } 5793 } else imp <- character() 5794 bad_imp <- setdiff(imports0, all_imports) 5795 5796 ## All the non-default packages need to be imported from. 5797 depends_not_import <- setdiff(depends, c(imp, default_package_names)) 5798 5799 methods_message <- 5800 if(uses_methods && "methods" %notin% c(depends, imports)) 5801 gettext("package 'methods' is used but not declared") 5802 else "" 5803 5804 extras <- list( 5805 base = c("Sys.junction", "shell", "shell.exec"), 5806 grDevices = c("X11.options", "X11Font", "X11Fonts", "quartz", 5807 "quartz.options", "quartz.save", "quartzFont", "quartzFonts", 5808 "bringToTop", "msgWindow", "win.graph", "win.metafile", "win.print", 5809 "windows", "windows.options", "windowsFont", "windowsFonts"), 5810 parallel = c("mccollect", "mcparallel", "mc.reset.stream", "mcaffinity"), 5811 utils = c("nsl", "DLL.version", "Filters", 5812 "choose.dir", "choose.files", "getClipboardFormats", 5813 "getIdentification", "getWindowsHandle", "getWindowsHandles", 5814 "getWindowTitle", "loadRconsole", "readClipboard", 5815 "readRegistry", "setStatusBar", "setWindowTitle", 5816 "shortPathName", "win.version", "winDialog", 5817 "winDialogString", "winMenuAdd", "winMenuAddItem", 5818 "winMenuDel", "winMenuDelItem", "winMenuNames", 5819 "winMenuItems", "writeClipboard", "zip.unpack", 5820 "winProgressBar", "getWinProgressBar", "setWinProgressBar", 5821 "setInternet2", "arrangeWindows"), 5822 RODBC = c("odbcConnectAccess", "odbcConnectAccess2007", 5823 "odbcConnectDbase", "odbcConnectExcel", "odbcConnectExcel2007") 5824 ) 5825 imp2un <- character() 5826 if(length(imp2)) { ## Try to check these are exported 5827 names(imp2f) <- imp2 5828 imp2 <- unique(imp2) 5829 imps <- split(imp2f, names(imp2f)) 5830 for (p in names(imps)) { 5831 ## some people have these quoted: 5832 this <- imps[[p]] 5833 this <- sub('^"(.*)"$', "\\1", this) 5834 this <- sub("^'(.*)'$", "\\1", this) 5835 if (p %in% "base") { 5836 this <- setdiff(this, ls(baseenv(), all.names = TRUE)) 5837 if(length(this)) 5838 imp2un <- c(imp2un, paste(p, this, sep = "::")) 5839 next 5840 } 5841 ns <- .getNamespace(p) 5842 value <- if(is.null(ns)) { 5843 ## this could be noisy 5844 tryCatch(suppressWarnings(suppressMessages(loadNamespace(p))), 5845 error = function(e) e) 5846 } else NULL 5847 if (!inherits(value, "error")) { 5848 ns <- asNamespace(p) 5849 exps <- c(ls(envir = .getNamespaceInfo(ns, "exports"), 5850 all.names = TRUE), 5851 ls(envir = .getNamespaceInfo(ns, "lazydata"), 5852 all.names = TRUE), 5853 extras[[p]]) 5854 this2 <- setdiff(this, exps) 5855 if(length(this2)) 5856 imp2un <- c(imp2un, paste(p, this2, sep = "::")) 5857 } 5858 } 5859 } 5860 5861 names(imp3f) <- imp3 5862 ## Eliminate some methods ::: self-calls which we know are in fact 5863 ## necessary. 5864 if(pkg_name == "methods") { 5865 imp3f <- imp3f[(imp3 != "methods") | 5866 (imp3f %notin% c(".class1", 5867 ".missingMethod", 5868 ".selectDotsMethod", 5869 ".setDummyField"))] 5870 imp3 <- names(imp3f) 5871 } 5872 imp3 <- unique(imp3) 5873 imp3self <- pkg_name %in% imp3 5874 imp3selfcalls <- as.vector(imp3f[names(imp3f) == pkg_name]) 5875 imp3 <- setdiff(imp3, pkg_name) 5876 if(length(imp3)) { 5877 imp3f <- imp3f[names(imp3f) %in% imp3] 5878 imps <- split(imp3f, names(imp3f)) 5879 imp32 <- imp3 <- imp3f <- imp3ff <- unknown <- character() 5880 for (p in names(imps)) { 5881 this <- imps[[p]] 5882 this <- sub('^"(.*)"$', "\\1", this) 5883 this <- sub("^'(.*)'$", "\\1", this) 5884 if (p %in% "base") { 5885 imp32 <- c(imp32, paste(p, this, sep = ":::")) 5886 next 5887 } 5888 ns <- .getNamespace(p) 5889 value <- if(is.null(ns)) { 5890 ## this could be noisy 5891 tryCatch(suppressWarnings(suppressMessages(loadNamespace(p))), 5892 error = function(e) e) 5893 } else NULL 5894 if (inherits(value, "error")) { 5895 unknown <- c(unknown, p) 5896 } else { 5897 exps <- c(ls(envir = getNamespaceInfo(p, "exports"), 5898 all.names = TRUE), extras[[p]]) 5899 this2 <- this %in% exps 5900 if (any(this2)) 5901 imp32 <- c(imp32, paste(p, this[this2], sep = ":::")) 5902 if (any(!this2)) { 5903 imp3 <- c(imp3, p) 5904 this <- this[!this2] 5905 pp <- ls(envir = asNamespace(p), all.names = TRUE) 5906 this2 <- this %in% pp 5907 if(any(this2)) 5908 imp3f <- c(imp3f, paste(p, this[this2], sep = ":::")) 5909 if(any(!this2)) 5910 imp3ff <- c(imp3ff, paste(p, this[!this2], sep = ":::")) 5911 } 5912 } 5913 } 5914 if(length(imp3f)) { 5915 ## remove other packages which have the same maintainer, 5916 ## but report references to itself. Unless they should be :: . 5917 maintainers <- 5918 sapply(strsplit(imp3f, ":::", fixed = TRUE), 5919 function(p) { 5920 dfile <- system.file("DESCRIPTION", package = p[[1L]]) 5921 if(dfile == "") return("") 5922 unname(.read_description(dfile)["Maintainer"]) 5923 }) 5924 imp3f <- imp3f[(maintainers != db["Maintainer"])] 5925 } 5926 } else imp32 <- imp3f <- imp3ff <- unknown <- character() 5927 ## An unexported function only available on Windows, used in tools 5928 imp3ff <- setdiff(sort(unique(imp3ff)), "utils:::unpackPkgZip") 5929 res <- list(others = unique(bad_exprs), 5930 bad_practice = unique(bad_prac), 5931 imports = unique(bad_imports), 5932 imps = unique(bad_imps), 5933 in_depends = unique(bad_deps), 5934 unused_imports = bad_imp, 5935 depends_not_import = depends_not_import, 5936 imp2un = sort(unique(imp2un)), 5937 imp32 = sort(unique(imp32)), 5938 imp3 = imp3, imp3f = sort(unique(imp3f)), 5939 imp3ff = imp3ff, imp3self = imp3self, 5940 imp3selfcalls = sort(unique(imp3selfcalls)), 5941 imp3unknown = unknown, 5942 methods_message = methods_message) 5943 class(res) <- "check_packages_used" 5944 res 5945} 5946 5947format.check_packages_used <- 5948function(x, ...) 5949{ 5950 incoming <- 5951 identical(Sys.getenv("_R_CHECK_PACKAGES_USED_CRAN_INCOMING_NOTES_", 5952 "FALSE"), 5953 "TRUE") 5954 ignore_unused_imports <- 5955 config_val_to_logical(Sys.getenv("_R_CHECK_PACKAGES_USED_IGNORE_UNUSED_IMPORTS_", 5956 "FALSE")) 5957 5958 c(character(), 5959 if(length(xx <- x$imports)) { 5960 if(length(xx) > 1L) { 5961 c(gettext("'::' or ':::' imports not declared from:"), 5962 .pretty_format(sort(xx))) 5963 } else { 5964 gettextf("'::' or ':::' import not declared from: %s", sQuote(xx)) 5965 } 5966 }, 5967 if(length(xx <- x$others)) { 5968 if(length(xx) > 1L) { 5969 c(gettext("'library' or 'require' calls not declared from:"), 5970 .pretty_format(sort(xx))) 5971 } else { 5972 gettextf("'library' or 'require' call not declared from: %s", 5973 sQuote(xx)) 5974 } 5975 }, 5976 if(length(xx <- x$imps)) { 5977 if(length(xx) > 1L) { 5978 c(gettext("'loadNamespace' or 'requireNamespace' calls not declared from:"), 5979 .pretty_format(sort(xx))) 5980 } else { 5981 gettextf("'loadNamespace' or 'requireNamespace' call not declared from: %s", 5982 sQuote(xx)) 5983 } 5984 }, 5985 if(length(xx <- x$in_depends)) { 5986 msg <- " Please remove these calls from your code." 5987 if(length(xx) > 1L) { 5988 c(gettext("'library' or 'require' calls to packages already attached by Depends:"), 5989 .pretty_format(sort(xx)), msg) 5990 } else { 5991 c(gettextf("'library' or 'require' call to %s which was already attached by Depends.", 5992 sQuote(xx)), msg) 5993 } 5994 }, 5995 if(length(xx <- x$bad_practice)) { 5996 msg <- 5997 " Please use :: or requireNamespace() instead.\n See section 'Suggested packages' in the 'Writing R Extensions' manual." 5998 if(length(xx) > 1L) { 5999 c(gettext("'library' or 'require' calls in package code:"), 6000 .pretty_format(sort(xx)), msg) 6001 } else { 6002 c(gettextf("'library' or 'require' call to %s in package code.", 6003 sQuote(xx)), msg) 6004 } 6005 }, 6006 6007 if(length(xx <- x$unused_imports) && !ignore_unused_imports) { 6008 msg <- " All declared Imports should be used." 6009 if(length(xx) > 1L) { 6010 c(gettext("Namespaces in Imports field not imported from:"), 6011 .pretty_format(sort(xx)), msg) 6012 } else { 6013 c(gettextf("Namespace in Imports field not imported from: %s", 6014 sQuote(xx)), msg) 6015 } 6016 }, 6017 if(length(xx <- x$depends_not_import)) { 6018 msg <- c(" These packages need to be imported from (in the NAMESPACE file)", 6019 " for when this namespace is loaded but not attached.") 6020 if(length(xx) > 1L) { 6021 c(gettext("Packages in Depends field not imported from:"), 6022 .pretty_format(sort(xx)), msg) 6023 } else { 6024 c(gettextf("Package in Depends field not imported from: %s", 6025 sQuote(xx)), msg) 6026 } 6027 }, 6028 if(length(xx <- x$imp2un)) { 6029 if(length(xx) > 1L) { 6030 c(gettext("Missing or unexported objects:"), 6031 .pretty_format(sort(xx))) 6032 } else { 6033 gettextf("Missing or unexported object: %s", sQuote(xx)) 6034 } 6035 }, 6036 if(length(xx <- x$imp32)) { ## ' ' seems to get converted to dir quotes 6037 msg <- "See the note in ?`:::` about the use of this operator." 6038 msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L) 6039 if(length(xx) > 1L) { 6040 c(gettext("':::' calls which should be '::':"), 6041 .pretty_format(sort(xx)), msg) 6042 } else { 6043 c(gettextf("':::' call which should be '::': %s", 6044 sQuote(xx)), msg) 6045 } 6046 }, 6047 if(length(xx <- x$imp3ff)) { 6048 if(length(xx) > 1L) { 6049 c(gettext("Missing objects imported by ':::' calls:"), 6050 .pretty_format(sort(xx))) 6051 } else { 6052 gettextf("Missing object imported by a ':::' call: %s", 6053 sQuote(xx)) 6054 } 6055 }, 6056 if(length(xxx <- x$imp3f)) { ## ' ' seems to get converted to dir quotes 6057 msg <- "See the note in ?`:::` about the use of this operator." 6058 msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L) 6059 if(incoming) { 6060 z <- sub(":::.*", "", xxx) 6061 base <- unlist(.get_standard_package_names()[c("base", "recommended")]) 6062 if (any(z %in% base)) 6063 msg <- c(msg, 6064 " Including base/recommended package(s):", 6065 .pretty_format(intersect(base, z))) 6066 } 6067 if(length(xxx) > 1L) { 6068 c(gettext("Unexported objects imported by ':::' calls:"), 6069 .pretty_format(sort(xxx)), msg) 6070 } else if(length(xxx)) { 6071 c(gettextf("Unexported object imported by a ':::' call: %s", 6072 sQuote(xxx)), msg) 6073 } 6074 }, 6075 if(isTRUE(x$imp3self)) { 6076 msg <- 6077 c("There are ::: calls to the package's namespace in its code.", 6078 "A package almost never needs to use ::: for its own objects:") 6079 c(strwrap(paste(msg, collapse = " "), indent = 0L, exdent = 2L), 6080 .pretty_format(sort(x$imp3selfcalls))) 6081 }, 6082 if(length(xx <- x$imp3unknown)) { 6083 msg <- "See the note in ?`:::` about the use of this operator." 6084 msg <- strwrap(paste(msg, collapse = " "), indent = 2L, exdent = 2L) 6085 if(length(xx) > 1L) { 6086 c(gettext("Unavailable namespaces imported from by ':::' calls:"), 6087 .pretty_format(sort(xx)), msg) 6088 } else { 6089 c(gettextf("Unavailable namespace imported from by a ':::' call: %s", 6090 sQuote(xx)), msg) 6091 } 6092 }, 6093 if(length(xx <- x$data)) { 6094 if(length(xx) > 1L) { 6095 c(gettext("'data(package=)' calls not declared from:"), 6096 .pretty_format(sort(xx))) 6097 } else { 6098 gettextf("'data(package=)' call not declared from: %s", 6099 sQuote(xx)) 6100 } 6101 }, 6102 if(nzchar(x$methods_message)) { 6103 x$methods_message 6104 }) 6105} 6106 6107### * .check_packages_used_in_examples 6108 6109.check_packages_used_helper <- 6110function(db, files) 6111{ 6112 pkg_name <- db["Package"] 6113 depends <- .get_requires_from_package_db(db, "Depends") 6114 imports <- .get_requires_from_package_db(db, "Imports") 6115 suggests <- .get_requires_from_package_db(db, "Suggests") 6116 enhances <- .get_requires_from_package_db(db, "Enhances") 6117 6118 ## it is OK to refer to yourself and standard packages 6119 standard_package_names <- .get_standard_package_names()$base 6120 depends_suggests <- c(depends, imports, suggests, enhances, pkg_name, 6121 standard_package_names) 6122 ## the first argument could be named, or could be a variable name. 6123 ## we just have a stop list here. 6124 common_names <- c("pkg", "pkgName", "package", "pos") 6125 6126 bad_exprs <- character() 6127 bad_imports <- character() 6128 bad_data <- character() 6129 find_bad_exprs <- function(e) { 6130 if(is.call(e) || is.expression(e)) { 6131 Call <- deparse(e[[1L]])[1L] 6132 if(length(e) >= 2L) pkg <- deparse(e[[2L]]) 6133 if(Call %in% 6134 c("library", "require", "loadNamespace", "requireNamespace")) { 6135 if(length(e) >= 2L) { 6136 ## We need to remove '...': OTOH the argument could be NULL 6137 keep <- vapply(e, 6138 function(x) deparse(x)[1L] != "...", 6139 NA) 6140 mc <- match.call(baseenv()[[Call]], e[keep]) 6141 if(!is.null(pkg <- mc$package)) { 6142 pkg <- sub('^"(.*)"$', '\\1', pkg) 6143 ## <NOTE> 6144 ## Using code analysis, we really don't know which 6145 ## package was called if character.only = TRUE and 6146 ## the package argument is not a string constant. 6147 ## (Btw, what if character.only is given a value 6148 ## which is an expression evaluating to TRUE?) 6149 dunno <- FALSE 6150 pos <- which(!is.na(pmatch(names(e), 6151 "character.only"))) 6152 if(length(pos) 6153 && isTRUE(e[[pos]]) 6154 && !identical(class(e[[2L]]), "character")) 6155 dunno <- TRUE 6156 ## </NOTE> 6157 if(! dunno 6158 && pkg %notin% c(depends_suggests, common_names)) 6159 bad_exprs <<- c(bad_exprs, pkg) 6160 } 6161 } 6162 } else if(Call %in% "::") { 6163 if(! pkg %in% depends_suggests) 6164 bad_imports <<- c(bad_imports, pkg) 6165 } else if(Call %in% ":::") { 6166 if(! pkg %in% depends_suggests) 6167 bad_imports <<- c(bad_imports, pkg) 6168 } else if((Call %in% "data" && length(e) >= 3L) || 6169 (Call %in% c("utils::data", "utils:::data"))) { 6170 mc <- match.call(utils::data, e) 6171 if(is.character(pkg <- mc$package) && pkg %notin% depends_suggests) 6172 bad_data <<- c(bad_data, pkg) 6173 } 6174 6175 for(i in seq_along(e)) Recall(e[[i]]) 6176 } 6177 } 6178 6179 if (is.character(files)) { 6180 for (f in files) { 6181 tryCatch({ 6182 ## This can give errors because the vignette etc 6183 ## need not be in the session encoding. 6184 exprs <- parse(file = f, n = -1L) 6185 for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]]) 6186 }, 6187 error = function(e) { 6188 ## so ignore 'invalid multibyte character' errors. 6189 msg <- .massage_file_parse_error_message(conditionMessage(e)) 6190 if(!startsWith(msg, "invalid multibyte character")) 6191 warning(gettextf("parse error in file '%s':\n%s", 6192 f, msg), 6193 domain = NA, call. = FALSE) 6194 }) 6195 } 6196 } else { 6197 ## called for examples with translation 6198 tryCatch({ 6199 exprs <- parse(file = files, n = -1L) 6200 for(i in seq_along(exprs)) find_bad_exprs(exprs[[i]]) 6201 }, 6202 error = function(e) 6203 warning(gettextf("parse error in file '%s':\n%s", 6204 summary(files)$description, 6205 .massage_file_parse_error_message(conditionMessage(e))), 6206 domain = NA, call. = FALSE)) 6207 } 6208 6209 res <- list(others = unique(bad_exprs), 6210 imports = unique(bad_imports), 6211 data = unique(bad_data), 6212 methods_message = "") 6213 class(res) <- "check_packages_used" 6214 res 6215} 6216 6217.check_packages_used_in_examples <- 6218function(package, dir, lib.loc = NULL) 6219{ 6220 ## Argument handling. 6221 if(!missing(package)) { 6222 if(length(package) != 1L) 6223 stop("argument 'package' must be of length 1") 6224 dir <- find.package(package, lib.loc) 6225 dfile <- file.path(dir, "DESCRIPTION") 6226 db <- .read_description(dfile) 6227 } 6228 else if(!missing(dir)) { 6229 ## Using sources from directory @code{dir} ... 6230 ## FIXME: not yet supported by .createExdotR. 6231 if(!dir.exists(dir)) 6232 stop(gettextf("directory '%s' does not exist", dir), domain = NA) 6233 else 6234 dir <- file_path_as_absolute(dir) 6235 dfile <- file.path(dir, "DESCRIPTION") 6236 db <- .read_description(dfile) 6237 } 6238 pkg_name <- db["Package"] 6239 6240 file <- .createExdotR(pkg_name, dir, silent = TRUE, 6241 commentDonttest = FALSE) 6242 if (is.null(file)) return(invisible(NULL)) # e.g, no examples 6243 on.exit(unlink(file)) 6244 enc <- db["Encoding"] 6245 if(!is.na(enc) && 6246 (Sys.getlocale("LC_CTYPE") %notin% c("C", "POSIX"))) { 6247 ## Avoid conversion failing on e.g. UTF-8 comments 6248 ## con <- file(file, encoding = enc) 6249 lines <- iconv(readLines(file, warn = FALSE), 6250 from = "UTF-8", to = "", sub = "byte") 6251 con <- textConnection(lines) 6252 on.exit(close(con), add = TRUE) 6253 } else con <- file 6254 6255 .check_packages_used_helper(db, con) 6256} 6257 6258 6259### * .check_packages_used_in_tests 6260 6261.check_packages_used_in_tests <- 6262function(dir, testdir, lib.loc = NULL) 6263{ 6264 ## Argument handling. 6265 ## Using sources from directory @code{dir} ... 6266 if(!dir.exists(dir)) 6267 stop(gettextf("directory '%s' does not exist", dir), domain = NA) 6268 else 6269 dir <- file_path_as_absolute(dir) 6270 dfile <- file.path(dir, "DESCRIPTION") 6271 db <- .read_description(dfile) 6272 6273 testsrcdir <- file.path(dir, testdir) 6274 od <- setwd(testsrcdir) 6275 on.exit(setwd(od)) 6276 Rinfiles <- list.files(".", pattern = "\\.Rin$") 6277 Rfiles <- list.files(".", pattern = "\\.[rR]$") 6278 if(testdir != "tests") { 6279 use_subdirs <- FALSE 6280 } else { 6281 use_subdirs <- 6282 Sys.getenv("_R_CHECK_PACKAGES_USED_IN_TESTS_USE_SUBDIRS_", 6283 "FALSE") 6284 use_subdirs <- config_val_to_logical(use_subdirs) 6285 if(use_subdirs) { 6286 subdirs <- c("testthat", "testit", "unitizer", "RUnit") 6287 subdirs <- subdirs[dir.exists(subdirs)] 6288 if(length(subdirs)) { 6289 Rfiles <- 6290 c(Rfiles, 6291 unlist(lapply(subdirs, list.files, 6292 pattern = "\\.[rR]$", 6293 full.names = TRUE), 6294 use.names = FALSE)) 6295 } else { 6296 use_subdirs <- FALSE 6297 } 6298 } 6299 } 6300 res <- .check_packages_used_helper(db, c(Rinfiles, Rfiles)) 6301 if(use_subdirs && any(lengths(bad <- res[1L : 3L]))) { 6302 ## Filter results against available package names to avoid (too 6303 ## many) false positives. 6304 ## <FIXME> 6305 ## Should really standardize getting available packages when 6306 ## checking. 6307 repos <- .get_standard_repository_URLs() 6308 available <- utils::available.packages(repos = repos) 6309 res[1L : 3L] <- lapply(bad, intersect, available[, "Package"]) 6310 } 6311 res 6312} 6313 6314### * .check_packages_used_in_vignettes 6315 6316.check_packages_used_in_vignettes <- 6317function(package, lib.loc = NULL) 6318{ 6319 ## Argument handling. 6320 if(missing(package) || length(package) != 1L) 6321 stop("argument 'package' must be of length 1") 6322 dir <- find.package(package, lib.loc) 6323 ## FIXME: use Meta directory. 6324 db <- .read_description(file.path(dir, "DESCRIPTION")) 6325 vinfo <- pkgVignettes(dir = dir, subdirs = "doc", source = TRUE) 6326 Rfiles <- unique(as.character(unlist(vinfo$sources))) 6327 .check_packages_used_helper(db, Rfiles) 6328} 6329 6330### * .check_T_and_F 6331 6332## T and F checking, next generation. 6333## 6334## What are we really trying to do? 6335## 6336## In R, T and F are "just" variables which upon startup are bound to 6337## TRUE and FALSE, respectively, in the base package/namespace. Hence, 6338## if code uses "global" variables T and F and dynamic lookup is in 6339## place (for packages, if they do not have a namespace), there may be 6340## trouble in case T or F were redefined. So we'd like to warn about 6341## these cases. 6342## 6343## A few things to note: 6344## * Package code top-level bindings *to* T and F are not a problem for 6345## packages installed for lazy-loading (as the top-level T and F get 6346## evaluated "appropriately" upon installation. 6347## * Code in examples using "global" T and F is always a problem, as 6348## this is evaluated in the global envionment by examples(). 6349## * There is no problem with package code using T and F as local 6350## variables. 6351## * Functions in a namespace will always find the T or F in the 6352## namespace, imports or base, never in the global environment. 6353## 6354## Our current idea is the following. Function findGlobals() in 6355## codetools already provides a way to (approximately) determine the 6356## globals. So we can try to get these and report them. 6357## 6358## Note that findGlobals() only works on closures, so we definitely miss 6359## top-level assignments to T or F. This could be taken care of rather 6360## easily, though. 6361## 6362## Note also that we'd like to help people find where the offending 6363## globals were found. Seems that codetools currently does not offer a 6364## way of recording e.g. the parent expression, so we do our own thing 6365## based on the legacy checkTnF code. 6366 6367.check_T_and_F <- 6368function(package, dir, lib.loc = NULL) 6369{ 6370 ## Seems that checking examples has several problems, and can result 6371 ## in "strange" diagnostic output. Let's more or less disable this 6372 ## for the time being. 6373 check_examples <- 6374 isTRUE(as.logical(Sys.getenv("_R_CHECK_RD_EXAMPLES_T_AND_F_"))) 6375 6376 6377 bad_closures <- character() 6378 bad_examples <- character() 6379 6380 find_bad_closures <- function(env) { 6381 x <- lapply(as.list(env, all.names = TRUE, sorted = TRUE), 6382 function(v) { 6383 if (typeof(v) == "closure") 6384 codetools::findGlobals(v) 6385 }) 6386 names(x)[vapply(x, function(s) any(s %in% c("T", "F")), NA)] 6387 } 6388 6389 find_bad_examples <- function(txts) { 6390 env <- new.env(hash = TRUE) # might be many 6391 x <- lapply(txts, 6392 function(txt) { 6393 tryCatch({ 6394 eval(str2expression( 6395 paste("FOO <- function() {", 6396 paste(txt, collapse = "\n"), 6397 "}", 6398 collapse = "\n")), 6399 env) 6400 find_bad_closures(env) 6401 }, 6402 error = function(e) character()) 6403 }) 6404 names(txts)[lengths(x) > 0L] 6405 } 6406 6407 if(!missing(package)) { 6408 if(length(package) != 1L) 6409 stop("argument 'package' must be of length 1") 6410 dir <- find.package(package, lib.loc) 6411 if((package != "base") 6412 && !packageHasNamespace(package, dirname(dir))) { 6413 .load_package_quietly(package, lib.loc) 6414 code_env <- .package_env(package) 6415 bad_closures <- find_bad_closures(code_env) 6416 } 6417 if(check_examples) 6418 example_texts <- 6419 .get_example_texts_from_example_dir(file.path(dir, "R-ex")) 6420 } 6421 else { 6422 ## The dir case. 6423 if(missing(dir)) 6424 stop("you must specify 'package' or 'dir'") 6425 dir <- file_path_as_absolute(dir) 6426 code_dir <- file.path(dir, "R") 6427 if(!packageHasNamespace(basename(dir), dirname(dir)) 6428 && dir.exists(code_dir)) { 6429 code_env <- new.env(hash = TRUE) 6430 dfile <- file.path(dir, "DESCRIPTION") 6431 meta <- if(file_test("-f", dfile)) 6432 .read_description(dfile) 6433 else 6434 character() 6435 .source_assignments_in_code_dir(code_dir, code_env, meta) 6436 bad_closures <- find_bad_closures(code_env) 6437 } 6438 if(check_examples) 6439 example_texts <- .get_example_texts_from_source_dir(dir) 6440 } 6441 6442 if(check_examples) 6443 bad_examples <- find_bad_examples(example_texts) 6444 6445 out <- list(bad_closures = bad_closures, 6446 bad_examples = bad_examples) 6447 class(out) <- "check_T_and_F" 6448 out 6449} 6450 6451.get_example_texts_from_example_dir <- 6452function(dir) 6453{ 6454 if(!dir.exists(dir)) return(NULL) 6455 files <- list_files_with_exts(dir, "R") 6456 texts <- lapply(files, 6457 function(f) paste(readLines(f, warn = FALSE), 6458 collapse = "\n")) 6459 names(texts) <- files 6460 texts 6461} 6462 6463.get_example_texts_from_source_dir <- 6464function(dir) 6465{ 6466 if(!dir.exists(file.path(dir, "man"))) return(NULL) 6467 lapply(Rd_db(dir = dir), .Rd_get_example_code) 6468} 6469 6470format.check_T_and_F <- 6471function(x, ...) 6472{ 6473 c(character(), 6474 if(length(x$bad_closures)) { 6475 msg <- ngettext(length(x$bad_closures), 6476 "Found possibly global 'T' or 'F' in the following function:", 6477 "Found possibly global 'T' or 'F' in the following functions:" 6478 ) 6479 c(strwrap(msg), 6480 .pretty_format(x$bad_closures)) 6481 }, 6482 if(length(x$bad_examples)) { 6483 msg <- ngettext(length(x$bad_examples), 6484 "Found possibly global 'T' or 'F' in the examples of the following Rd file:", 6485 "Found possibly global 'T' or 'F' in the examples of the following Rd files:" 6486 ) 6487 c(strwrap(msg), 6488 paste0(" ", x$bad_examples)) 6489 }) 6490} 6491 6492### * .check_bogus_return 6493 6494## Find bogus 'return' statements probably intended as a return() call. 6495## This uses codetools::findGlobals() to find functions which rely on a 6496## global variable "return". 6497## The code is derived from .check_T_and_F above. 6498 6499.check_bogus_return <- 6500function(package, dir, lib.loc = NULL) 6501{ 6502 bad_closures <- character() 6503 6504 find_bad_closures <- function(env) { 6505 x <- lapply(as.list(env, all.names = TRUE, sorted = TRUE), 6506 function(v) { 6507 if (typeof(v) == "closure") 6508 codetools::findGlobals(v, merge = FALSE)$variables 6509 }) 6510 names(x)[vapply(x, function(s) any(s %in% "return"), NA)] 6511 } 6512 6513 if(!missing(package)) { 6514 if(length(package) != 1L) 6515 stop("argument 'package' must be of length 1") 6516 dir <- find.package(package, lib.loc) 6517 if(package %notin% .get_standard_package_names()$base) { 6518 .load_package_quietly(package, lib.loc) 6519 code_env <- asNamespace(package) 6520 bad_closures <- find_bad_closures(code_env) 6521 } 6522 } 6523 else { 6524 ## The dir case. 6525 if(missing(dir)) 6526 stop("you must specify 'package' or 'dir'") 6527 dir <- file_path_as_absolute(dir) 6528 code_dir <- file.path(dir, "R") 6529 if(dir.exists(code_dir)) { 6530 code_env <- new.env(hash = TRUE) 6531 dfile <- file.path(dir, "DESCRIPTION") 6532 meta <- if(file_test("-f", dfile)) 6533 .read_description(dfile) 6534 else 6535 character() 6536 .source_assignments_in_code_dir(code_dir, code_env, meta) 6537 bad_closures <- find_bad_closures(code_env) 6538 } 6539 } 6540 6541 out <- list(bad_closures = bad_closures) 6542 class(out) <- "check_bogus_return" 6543 out 6544} 6545 6546format.check_bogus_return <- 6547function(x, ...) 6548{ 6549 c(character(), 6550 if(length(x$bad_closures)) { 6551 msg <- ngettext(length(x$bad_closures), 6552 "Possibly missing '()' after 'return' in the following function:", 6553 "Possibly missing '()' after 'return' in the following functions:" 6554 ) 6555 c(strwrap(msg), 6556 .pretty_format(x$bad_closures)) 6557 }) 6558} 6559 6560 6561### * .check_dotIntenal 6562 6563.check_dotInternal <- 6564function(package, dir, lib.loc = NULL, details = TRUE) 6565{ 6566 bad_closures <- character() 6567 6568 find_bad_closures <- function(env) { 6569 objects_in_env <- as.list(env, all.names = TRUE, sorted = TRUE) 6570 x <- lapply(objects_in_env, 6571 function(v) { 6572 if (typeof(v) == "closure") 6573 codetools::findGlobals(v) 6574 }) 6575 names(x)[vapply(x, function(s) any(s %in% ".Internal"), NA)] 6576 } 6577 6578 find_bad_S4methods <- function(env) { 6579 gens <- .get_S4_generics(code_env) 6580 x <- lapply(gens, function(f) { 6581 tab <- get(methods:::.TableMetaName(f, attr(f, "package")), 6582 envir = code_env) 6583 ## The S4 'system' does **copy** base code into packages .... 6584 any(unlist(eapply(tab, function(v) !inherits(v, "derivedDefaultMethod") && 6585 any(codetools::findGlobals(v) %in% ".Internal")))) 6586 }) 6587 gens[unlist(x)] 6588 } 6589 6590 find_bad_refClasses <- function(refs) { 6591 cl <- names(refs) 6592 x <- lapply(refs, function(z) { 6593 any(vapply(z, 6594 function(v) 6595 any(codetools::findGlobals(v) %in% 6596 ".Internal"), 6597 NA)) 6598 }) 6599 cl[unlist(x)] 6600 } 6601 6602 6603 bad_S4methods <- list() 6604 bad_refs <- character() 6605 if(!missing(package)) { 6606 if(length(package) != 1L) 6607 stop("argument 'package' must be of length 1") 6608 dir <- find.package(package, lib.loc) 6609 if(package %notin% .get_standard_package_names()$base) { 6610 .load_package_quietly(package, lib.loc) 6611 code_env <- if(packageHasNamespace(package, dirname(dir))) 6612 asNamespace(package) 6613 else .package_env(package) 6614 bad_closures <- find_bad_closures(code_env) 6615 if(.isMethodsDispatchOn()) { 6616 bad_S4methods <- find_bad_S4methods(code_env) 6617 refs <- .get_ref_classes(code_env) 6618 if(length(refs)) bad_refs <- find_bad_refClasses(refs) 6619 } 6620 } 6621 } 6622 else { 6623 ## The dir case. 6624 if(missing(dir)) 6625 stop("you must specify 'package' or 'dir'") 6626 dir <- file_path_as_absolute(dir) 6627 code_dir <- file.path(dir, "R") 6628 if(dir.exists(code_dir)) { 6629 code_env <- new.env(hash = TRUE) 6630 dfile <- file.path(dir, "DESCRIPTION") 6631 meta <- if(file_test("-f", dfile)) 6632 .read_description(dfile) 6633 else 6634 character() 6635 .source_assignments_in_code_dir(code_dir, code_env, meta) 6636 bad_closures <- find_bad_closures(code_env) 6637 } 6638 } 6639 6640 internals <- character() 6641 if (length(bad_closures) && details) { 6642 lapply(bad_closures, function(o) { 6643 v <- get(o, envir = code_env) 6644 calls <- .find_calls(v, recursive = TRUE) 6645 if(!length(calls)) return() 6646 calls <- calls[.call_names(calls) == ".Internal"] 6647 calls2 <- lapply(calls, "[", 2L) 6648 calls3 <- 6649 sapply(calls2, function(x) sub("\\(.*", "", deparse(x)[1L])) 6650 internals <<- c(internals, calls3) 6651 }) 6652 } 6653 out <- list(bad_closures = bad_closures, internals = internals, 6654 bad_S4methods = bad_S4methods, bad_refs = bad_refs) 6655 class(out) <- "check_dotInternal" 6656 out 6657} 6658 6659format.check_dotInternal <- 6660function(x, ...) 6661{ 6662 out <- if(length(x$bad_closures)) { 6663 msg <- ngettext(length(x$bad_closures), 6664 "Found a .Internal call in the following function:", 6665 "Found .Internal calls in the following functions:" 6666 ) 6667 out <- c(strwrap(msg), .pretty_format(x$bad_closures)) 6668 if (length(unique(x$internals))) 6669 out <- c(out, "with calls to .Internal functions", 6670 .pretty_format(sort(unique(x$internals)))) 6671 out 6672 } else character() 6673 if(length(x$bad_S4methods)) { 6674 msg <- ngettext(length(x$bad_S4methods), 6675 "Found a.Internal call in methods for the following S4 generic:", 6676 "Found .Internal calls in methods for the following S4 generics:" 6677 ) 6678 out <- c(out, strwrap(msg), .pretty_format(x$bad_S4methods)) 6679 } 6680 if(length(x$bad_refs)) { 6681 msg <- ngettext(length(x$bad_refs), 6682 "Found a .Internal call in methods for the following reference class:", 6683 "Found .Internal calls in methods for the following reference classes:" 6684 ) 6685 out <- c(out, strwrap(msg), .pretty_format(x$bad_refs)) 6686 } 6687 out 6688} 6689 6690### * .check_namespace 6691 6692.check_namespace <- 6693function(dir) 6694{ 6695 dir <- file_path_as_absolute(dir) 6696 invisible(tryCatch(parseNamespaceFile(basename(dir), dirname(dir)), 6697 error = function(e) { 6698 writeLines("Invalid NAMESPACE file, parsing gives:") 6699 stop(e) 6700 })) 6701} 6702 6703### * .check_citation 6704 6705.check_citation <- 6706function(cfile, dir = NULL) 6707{ 6708 cfile <- file_path_as_absolute(cfile) 6709 6710 if(!is.null(dir)) { 6711 meta <- utils::packageDescription(basename(dir), dirname(dir)) 6712 db <- .read_citation_quietly(cfile, meta) 6713 if(inherits(db, "error")) { 6714 msg <- conditionMessage(db) 6715 call <- conditionCall(db) 6716 if(is.null(call)) 6717 msg <- c("Error: ", msg) 6718 else 6719 msg <- c("Error in ", deparse(call), ": ", msg) 6720 writeLines(paste(msg, collapse = "")) 6721 } 6722 return(invisible()) 6723 } 6724 6725 meta <- if(basename(dir <- dirname(cfile)) == "inst") 6726 as.list(.get_package_metadata(dirname(dir))) 6727 else 6728 NULL 6729 6730 db <- tryCatch(suppressMessages(get_CITATION_entry_fields(cfile, 6731 meta$Encoding)), 6732 error = identity) 6733 6734 if(inherits(db, "error")) { 6735 writeLines(conditionMessage(db)) 6736 return(invisible()) 6737 } 6738 6739 if(!NROW(db)) return(invisible()) 6740 6741 bad <- Map(find_missing_required_BibTeX_fields, db$Entry, db$Fields, 6742 USE.NAMES = FALSE) 6743 ind <- vapply(bad, identical, NA_character_, FUN.VALUE = NA) 6744 if(length(pos <- which(ind))) { 6745 entries <- db$Entry[pos] 6746 entries <- 6747 ifelse(nchar(entries) < 20L, 6748 entries, 6749 paste(substr(entries, 1L, 20L), "[TRUNCATED]")) 6750 writeLines(sprintf("entry %d: invalid type %s", 6751 pos, sQuote(entries))) 6752 } 6753 pos <- which(!ind & (lengths(bad) > 0L)) 6754 if(length(pos)) { 6755 writeLines(strwrap(sprintf("entry %d (%s): missing required field(s) %s", 6756 pos, 6757 db$Entry[pos], 6758 vapply(bad[pos], 6759 function(s) 6760 paste(sQuote(s), 6761 collapse = ", "), 6762 "")), 6763 indent = 0L, exdent = 2L)) 6764 } 6765} 6766 6767### * .check_package_parseRd 6768 6769## FIXME: could use dumped files, except for use of encoding = "ASCII" 6770.check_package_parseRd <- 6771function(dir, silent = FALSE, def_enc = FALSE, minlevel = -1) 6772{ 6773 if(file.exists(dfile <- file.path(dir, "DESCRIPTION"))) { 6774 enc <- read.dcf(dfile)[1L, ]["Encoding"] 6775 if(is.na(enc)) enc <- "ASCII" 6776 else def_enc <- TRUE 6777 } else enc <- "ASCII" 6778 macros <- loadPkgRdMacros(dir) 6779 ## UGLY! FIXME: add (something like) 'dir' as argument to checkRd() below! 6780 oenv <- Sys.getenv("_R_RD_MACROS_PACKAGE_DIR_", unset = NA) 6781 on.exit(if (!is.na(oenv)) Sys.setenv("_R_RD_MACROS_PACKAGE_DIR_" = oenv) 6782 else Sys.unsetenv("_R_RD_MACROS_PACKAGE_DIR_")) 6783 Sys.setenv("_R_RD_MACROS_PACKAGE_DIR_" = normalizePath(dir)) 6784 6785 pg <- dir("man", pattern = "[.][Rd]d$", full.names = TRUE) 6786 bad <- character() 6787 for (f in pg) { 6788 ## Kludge for now 6789 if(basename(f) %in% c("iconv.Rd", "showNonASCII.Rd")) def_enc <- TRUE 6790 ## FIXME: this may not work for no/fake install if the expressions 6791 ## involve the package under check. 6792 tmp <- tryCatch(suppressMessages(checkRd(f, encoding = enc, 6793 def_enc = def_enc, 6794 macros = macros, 6795 stages = c("build", "install", "render"))), 6796 error = identity) 6797 if(inherits(tmp, "error")) { 6798 bad <- c(bad, f) 6799 if(!silent) message(geterrmessage()) 6800 } else print(tmp, minlevel = minlevel) 6801 } 6802 if(length(bad)) bad <- sQuote(sub(".*/", "", bad)) 6803 if(length(bad) > 1L) 6804 cat("problems found in ", paste(bad, collapse=", "), "\n", sep = "") 6805 else if(length(bad)) 6806 cat("problem found in ", bad, "\n", sep = "") 6807 invisible() 6808} 6809 6810 6811### * .check_depdef 6812 6813.check_depdef <- 6814function(package, dir, lib.loc = NULL, WINDOWS = FALSE) 6815{ 6816 bad_depr <- c("plclust") 6817 6818 bad_def <- c("La.eigen", "tetragamma", "pentagamma", 6819 "package.description", "gammaCody", 6820 "manglePackageName", ".readRDS", ".saveRDS", 6821 "mem.limits", "trySilent", "traceOn", "traceOff", 6822 "print.coefmat", "anovalist.lm", "lm.fit.null", 6823 "lm.wfit.null", "glm.fit.null", "tkcmd", 6824 "tkfile.tail", "tkfile.dir", "tkopen", "tkclose", 6825 "tkputs", "tkread", "Rd_parse", "CRAN.packages", 6826 "zip.file.extract", 6827 "real", "as.real", "is.real", 6828 ".find.package", ".path.package") 6829 6830 ## X11 may not work on even a Unix-alike: it needs X support 6831 ## (optional) at install time and an X server at run time. 6832 bad_dev <- c("quartz", "x11", "X11") 6833 if(!WINDOWS) 6834 bad_dev <- c(bad_dev, "windows", "win.graph", "win.metafile", "win.print") 6835 6836 bad <- c(bad_depr, bad_def, bad_dev) 6837 bad_closures <- character() 6838 found <- character() 6839 6840 find_bad_closures <- function(env) { 6841 objects_in_env <- as.list(env, all.names = TRUE, sorted = TRUE) 6842 x <- lapply(objects_in_env, 6843 function(v) { 6844 if (typeof(v) == "closure") 6845 codetools::findGlobals(v) 6846 }) 6847 names(x)[vapply(x, 6848 function(s) { 6849 res <- any(s %in% bad) 6850 if(res) found <<- c(found, s) 6851 res 6852 }, 6853 NA)] 6854 } 6855 6856 find_bad_S4methods <- function(env) { 6857 gens <- .get_S4_generics(code_env) 6858 x <- lapply(gens, function(f) { 6859 tab <- get(methods:::.TableMetaName(f, attr(f, "package")), 6860 envir = code_env) 6861 ## The S4 'system' does **copy** base code into packages .... 6862 any(unlist(eapply(tab, function(v) { 6863 if(!inherits(v, "derivedDefaultMethod")) FALSE 6864 else { 6865 s <- codetools::findGlobals(v) 6866 found <<- c(found, s) 6867 any(s %in% bad) 6868 } 6869 }))) 6870 }) 6871 gens[unlist(x)] 6872 } 6873 6874 find_bad_refClasses <- function(refs) { 6875 cl <- names(refs) 6876 x <- lapply(refs, function(z) { 6877 any(vapply(z, 6878 function(v) { 6879 s <- codetools::findGlobals(v) 6880 found <<- c(found, s) 6881 any(s %in% bad) 6882 }, 6883 NA)) 6884 }) 6885 cl[unlist(x)] 6886 } 6887 6888 6889 ## FIXME: these are set but not used. 6890 bad_S4methods <- list() 6891 bad_refs <- character() 6892 if(!missing(package)) { 6893 if(length(package) != 1L) 6894 stop("argument 'package' must be of length 1") 6895 dir <- find.package(package, lib.loc) 6896 if(package %notin% .get_standard_package_names()$base) { 6897 .load_package_quietly(package, lib.loc) 6898 code_env <- if(packageHasNamespace(package, dirname(dir))) 6899 asNamespace(package) 6900 else .package_env(package) 6901 bad_closures <- find_bad_closures(code_env) 6902 if(.isMethodsDispatchOn()) { 6903 bad_S4methods <- find_bad_S4methods(code_env) 6904 refs <- .get_ref_classes(code_env) 6905 if(length(refs)) bad_refs <- find_bad_refClasses(refs) 6906 } 6907 } 6908 } 6909 else { 6910 ## The dir case. 6911 if(missing(dir)) 6912 stop("you must specify 'package' or 'dir'") 6913 dir <- file_path_as_absolute(dir) 6914 code_dir <- file.path(dir, "R") 6915 if(dir.exists(code_dir)) { 6916 code_env <- new.env(hash = TRUE) 6917 dfile <- file.path(dir, "DESCRIPTION") 6918 meta <- if(file_test("-f", dfile)) 6919 .read_description(dfile) 6920 else 6921 character() 6922 .source_assignments_in_code_dir(code_dir, code_env, meta) 6923 bad_closures <- find_bad_closures(code_env) 6924 } 6925 } 6926 6927 found <- sort(unique(found)) 6928 deprecated <- found[found %in% bad_depr] 6929 defunct <- found[found %in% bad_def] 6930 devices <- found[found %in% bad_dev] 6931 6932 out <- list(bad_closures = bad_closures, deprecated = deprecated, 6933 defunct = defunct, devices = devices) 6934 class(out) <- "check_depdef" 6935 out 6936} 6937 6938format.check_depdef <- 6939function(x, ...) 6940{ 6941 out <- if(length(x$bad_closures)) { 6942 msg <- ngettext(length(x$bad_closures), 6943 "Found an obsolete/platform-specific call in the following function:", 6944 "Found an obsolete/platform-specific call in the following functions:" 6945 ) 6946 c(strwrap(msg), .pretty_format(x$bad_closures)) 6947 } else character() 6948 if(length(x$bad_S4methods)) { 6949 msg <- ngettext(length(x$bad_S4methods), 6950 "Found an obsolete/platform-specific call in methods for the following S4 generic:", 6951 "Found an obsolete/platform-specific call in methods for the following S4 generics:" 6952 ) 6953 out <- c(out, strwrap(msg), .pretty_format(x$bad_S4methods)) 6954 } 6955 if(length(x$bad_refs)) { 6956 msg <- ngettext(length(x$bad_refs), 6957 "Found an obsolete/platform-specific call in methods for the following reference class:", 6958 "Found an obsolete/platform-specific call in methods for the following reference classes:" 6959 ) 6960 out <- c(out, strwrap(msg), .pretty_format(x$bad_refs)) 6961 } 6962 if(length(x$deprecated)) { 6963 msg <- ngettext(length(x$deprecated), 6964 "Found the deprecated function:", 6965 "Found the deprecated functions:" 6966 ) 6967 out <- c(out, strwrap(msg), .pretty_format(x$deprecated)) 6968 } 6969 if(length(x$defunct)) { 6970 msg <- ngettext(length(x$defunct), 6971 "Found the defunct/removed function:", 6972 "Found the defunct/removed functions:" 6973 ) 6974 out <- c(out, strwrap(msg), .pretty_format(x$defunct)) 6975 } 6976 if(length(x$devices)) { 6977 msg <- ngettext(length(x$devices), 6978 "Found the platform-specific device:", 6979 "Found the platform-specific devices:" 6980 ) 6981 out <- c(out, strwrap(msg), .pretty_format(x$devices), 6982 strwrap(paste("dev.new() is the preferred way to open a new device,", 6983 "in the unlikely event one is needed.", 6984 collapse = " "))) 6985 } 6986 out 6987} 6988 6989### * .check_package_CRAN_incoming 6990 6991## localOnly means to skip tests requiring Internet access. 6992## These are all done first. 6993 6994.check_package_CRAN_incoming <- 6995function(dir, localOnly = FALSE, pkgSize = NA) 6996{ 6997 out <- list() 6998 class(out) <- "check_package_CRAN_incoming" 6999 7000 meta <- .get_package_metadata(dir, FALSE) 7001 lic_info <- analyze_license(meta["License"]) 7002 ## Use later to indicate changes from FOSS to non-FOSS licence. 7003 foss <- lic_info$is_verified 7004 ## Record to notify about components extending a base license which 7005 ## permits extensions. 7006 if(length(extensions <- lic_info$extensions) && 7007 ((length(components <- extensions$components) != 1L) || 7008 (.license_component_is_for_stub_and_ok(components, 7009 dir) != 0L)) && 7010 any(ind <- extensions$extensible)) { 7011 out$extensions <- extensions$components[ind] 7012 out$pointers <- 7013 Filter(length, 7014 lapply(lic_info$pointers, 7015 function(p) { 7016 fp <- file.path(dir, p) 7017 if(file_test("-f", fp)) { 7018 lines <- readLines(fp, warn = FALSE) 7019 ## Should this use the package 7020 ## encoding? 7021 ## (no, as we have LICENSE files with 7022 ## copyright signs in ASCII packages) 7023 pos <- grep("[^[:blank:]]", lines, 7024 useBytes = TRUE) 7025 c(p, if(len <- length(pos)) { 7026 lines[seq.int(from = pos[1L], 7027 to = pos[len])] 7028 }) 7029 } else NULL 7030 })) 7031 } 7032 7033 out$Maintainer <- meta["Maintainer"] 7034 ## pick out 'display name' 7035 display <- gsub("<.*", "", as.vector(out$Maintainer)) 7036 display <- sub("[[:space:]]+$", "", 7037 sub("^[[:space:]]+", "", display, useBytes = TRUE), 7038 useBytes = TRUE) 7039 ## RFC 5322 allows '.' in the display name, but 2822 did not. 7040 ## ',' separates email addresses. 7041 if(grepl("[,]", display, useBytes = TRUE) && 7042 !grepl('^".*"$', display, useBytes = TRUE)) 7043 out$Maintainer_needs_quotes <- TRUE 7044 if(!nzchar(display)) 7045 out$empty_Maintainer_name <- TRUE 7046 ## Try to catch bad maintainer fields which give more than one 7047 ## person. In principle, the field should be of the form 7048 ## DISPLAY-NAME <ANGLE-ADDR> 7049 ## with the former (for simplicity) either a single quoted string, 7050 ## or several atoms. (There are cases where <ANGLE-ADDR> does not 7051 ## follow whitespace, so simple tokenizing via scan() does not quite 7052 ## work.) 7053 check_maintainer_address <- function(s) { 7054 re <- paste0("^", 7055 "[[:space:]]*", 7056 "([^<]*|\"([^\"]|\\\\\")*\")", # display-name 7057 "[[:space:]]*", 7058 "(<[^>]+>)", # angle-addr 7059 "[[:space:]]*", 7060 "(.*)", # rest? 7061 "[[:space:]]*", 7062 "$") 7063 s <- unlist(regmatches(s, regexec(re, s))) 7064 length(s) && (s[5L] == "") ## && (s[2L] != "") 7065 ## (Adding the test for s[2L] would check for non-empty 7066 ## display-name which we already do separately.) 7067 } 7068 ## NOTE: perhaps whitespace should be canonicalized further above? 7069 maintainer <- gsub("\n", " ", meta["Maintainer"], fixed = TRUE) 7070 if((maintainer != "ORPHANED") && 7071 !check_maintainer_address(maintainer)) 7072 out$Maintainer_invalid_or_multi_person <- TRUE 7073 7074 ver <- meta["Version"] 7075 if(is.na(ver)) 7076 stop("Package has no 'Version' field", call. = FALSE) 7077 if(grepl("(^|[.-])0[0-9]+", ver)) 7078 out$version_with_leading_zeroes <- ver 7079 unlisted_version <- unlist(package_version(ver)) 7080 if(any(unlisted_version >= 1234 & 7081 unlisted_version != as.integer(format(Sys.Date(), "%Y"))) && 7082 !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_LARGE_VERSION_", 7083 "FALSE"))) 7084 out$version_with_large_components <- ver 7085 7086 .aspell_package_description_for_CRAN <- function(dir, meta = NULL) { 7087 if(!is.null(meta)) { 7088 dir.create(dir <- tempfile(pattern = "aspell")) 7089 on.exit(unlink(dir, recursive = TRUE)) 7090 .write_description(meta, file.path(dir, "DESCRIPTION")) 7091 } 7092 ignore <- 7093 list(c("(?<=[ \t[:punct:]])'[^']*'(?=[ \t[:punct:]])", 7094 "(?<=[ \t[:punct:]])([[:alnum:]]+::)?[[:alnum:]_.]*\\(\\)(?=[ \t[:punct:]])", 7095 "(?<=[<])(https?://|DOI:|doi:|arXiv:)[^>]+(?=[>])"), 7096 perl = TRUE) 7097 utils:::aspell_package_description(dir, 7098 ignore = ignore, 7099 control = 7100 c("--master=en_US", 7101 "--add-extra-dicts=en_GB"), 7102 program = "aspell", 7103 dictionaries = "en_stats") 7104 } 7105 7106 language <- meta["Language"] 7107 if((is.na(language) || 7108 (language == "en") || 7109 startsWith(language, "en-")) && 7110 config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_USE_ASPELL_", 7111 "FALSE"))) { 7112 a <- .aspell_package_description_for_CRAN(dir) 7113 if(NROW(a)) 7114 out$spelling <- a 7115 } 7116 7117 parse_description_field <- function(desc, field, default) 7118 str_parse_logic(desc[field], default=default) 7119 7120 ## Check for possibly mis-spelled field names. 7121 nms <- names(meta) 7122 stdNms <- .get_standard_DESCRIPTION_fields() 7123 nms <- nms[nms %notin% stdNms & 7124 !grepl(paste0("^(", 7125 paste(c("X-CRAN", 7126 "X-schema.org", 7127 "Repository/R-Forge", 7128 "VCS/", 7129 "Config/"), 7130 collapse = "|"), 7131 ")"), 7132 nms)] 7133 if(length(nms) && ## Allow maintainer notes <stdName>Note : 7134 length(nms <- nms[nms %notin% paste0(stdNms,"Note")])) 7135 out$fields <- nms 7136 7137 7138 uses <- character() 7139 BUGS <- character() 7140 for (field in c("Depends", "Imports", "Suggests")) { 7141 p <- strsplit(meta[field], " *, *")[[1L]] 7142 p2 <- grep("^(multicore|snow|igraph0|doSNOW)( |\\(|$)", p, value = TRUE) 7143 uses <- c(uses, p2) 7144 p2 <- grep("^(BRugs|R2OpenBUGS|R2WinBUGS)( |\\(|$)", p, value = TRUE) 7145 BUGS <- c(BUGS, p2) 7146 } 7147 if (length(uses)) 7148 out$uses <- sort(unique(gsub("[[:space:]]+", " ", uses))) 7149 if (length(BUGS)) 7150 out$BUGS <- sort(unique(gsub("[[:space:]]+", " ", BUGS))) 7151 7152 ## Check for non-Sweave vignettes (as indicated by the presence of a 7153 ## 'VignetteBuilder' field in DESCRIPTION) without 7154 ## 'build/vignette.rds'. 7155 7156 vds <- character() 7157 if(!is.na(meta["VignetteBuilder"])) { 7158 if(!file.exists(vds <- file.path(dir, "build", "vignette.rds"))) 7159 out$missing_vignette_index <- TRUE 7160 else 7161 vds <- readRDS(vds)[, "File"] 7162 } 7163 7164 ## Check for missing build/{partial.rdb,pkgname.pdf} 7165 ## copy code from build.R 7166 Rdb <- .build_Rd_db(dir, stages = NULL, 7167 os = c("unix", "windows"), step = 1) 7168 if(length(Rdb)) { 7169 names(Rdb) <- 7170 substring(names(Rdb), nchar(file.path(dir, "man")) + 2L) 7171 containsBuildSexprs <- 7172 any(vapply(Rdb, 7173 function(Rd) any(getDynamicFlags(Rd)["build"]), 7174 NA)) 7175 if(containsBuildSexprs && 7176 !file.exists(file.path(dir, "build", "partial.rdb"))) 7177 out$missing_manual_rdb <- TRUE 7178 needRefMan <- 7179 any(vapply(Rdb, 7180 function(Rd) any(getDynamicFlags(Rd)[c("install", "render")]), 7181 NA)) 7182 if(needRefMan && 7183 !file.exists(file.path(dir, "build", 7184 paste0( meta[["Package"]], ".pdf")))) 7185 out$missing_manual_pdf <- TRUE 7186 ## Also check for \keyword and \concept entries which use Rd 7187 ## markup or (likely) give multiple index terms. 7188 ## This could be moved to .check_Rd_metadata() ... 7189 .fmt <- function(x) { 7190 Map(function(f, e) { 7191 e <- vapply(e, .Rd_deparse, "") 7192 c(paste0(" File ", sQuote(f), ":"), 7193 paste0(" ", 7194 gsub("\n", 7195 "\n ", 7196 ifelse(nchar(e) < 50L, 7197 e, 7198 paste(substr(e, 1L, 50L), 7199 "[TRUNCATED]"))))) 7200 }, 7201 names(x), x) 7202 } 7203 bad <- lapply(Rdb, 7204 function(Rd) { 7205 Rd <- Rd[RdTags(Rd) %in% c("\\keyword", "\\concept")] 7206 Rd[vapply(Rd, 7207 function(e) 7208 any(unlist(RdTags(e)) != "TEXT"), 7209 NA)] 7210 }) 7211 bad <- Filter(length, bad) 7212 if(length(bad)) 7213 out$Rd_keywords_or_concepts_with_Rd_markup <- .fmt(bad) 7214 bad <- lapply(Rdb, 7215 function(Rd) { 7216 Rd <- Rd[RdTags(Rd) %in% c("\\keyword", "\\concept")] 7217 Rd[grepl("[,\n]", 7218 trimws(vapply(Rd, paste, "", 7219 collapse = "\n"))) & 7220 !vapply(Rd, 7221 function(e) 7222 any(unlist(RdTags(e)) != "TEXT"), 7223 NA)] 7224 }) 7225 bad <- Filter(length, bad) 7226 if(length(bad)) 7227 out$Rd_keywords_or_concepts_more_than_one <- .fmt(bad) 7228 ## Also check for URLs which should use \doi with the DOI name. 7229 .fmt <- function(x) { 7230 Map(function(f, e) { 7231 c(paste0(" File ", sQuote(f), ":"), 7232 paste0(" ", e)) 7233 }, 7234 names(x), x) 7235 } 7236 bad <- lapply(Rdb, 7237 function(Rd) { 7238 grep("https?://(dx[.])?doi[.]org/10", 7239 .get_urls_from_Rd(Rd), 7240 value = TRUE) 7241 }) 7242 bad <- Filter(length, bad) 7243 if(length(bad)) 7244 out$Rd_URLs_which_should_use_doi <- .fmt(bad) 7245 } 7246 7247 7248 ## Check for vignette source (only) in old-style 'inst/doc' rather 7249 ## than 'vignettes'. 7250 vign_dir <- file.path(dir, "vignettes") 7251 if(length(vds)) { 7252 sources <- setdiff(list.files(file.path(dir, "inst", "doc")), 7253 list.files(vign_dir)) 7254 sources <- intersect(vds, sources) 7255 } else { 7256 pattern <- vignetteEngine("Sweave")$pattern 7257 sources <- setdiff(list.files(file.path(dir, "inst", "doc"), 7258 pattern = pattern), 7259 list.files(vign_dir, pattern = pattern)) 7260 } 7261 7262 if(length(sources)) { 7263 out$have_vignettes_dir <- dir.exists(vign_dir) 7264 out$vignette_sources_only_in_inst_doc <- sources 7265 } 7266 7267 ## Check for Java files without sources (in the right place) 7268 ## NB: this is only a basic check: that directory need 7269 ## not contain all (or any) of the sources. 7270 ## We might in due course want to prompt looking into it. 7271 if (foss && !dir.exists(file.path(dir, "java"))) { 7272 allfiles <- list.files(file.path(dir, "inst"), 7273 full.names = TRUE, recursive = TRUE) 7274 allfiles <- c(allfiles, # misused by ndtv, sisus 7275 list.files(file.path(dir, "exec"), full.names = TRUE)) 7276 javafiles <- grep(".*[.](class|jar)$", allfiles, value = TRUE) 7277 if(length(javafiles)) out$javafiles <- javafiles 7278 } 7279 7280 ## Check for installing Java source files 7281 { 7282 dotjava <- list.files(file.path(dir, "inst"), pattern = ".*[.]java$", 7283 full.names = TRUE, recursive = TRUE) 7284 dotjava <- c(dotjava, # misused by ndtv 7285 list.files(file.path(dir, "exec"), pattern = ".*[.]java$", 7286 full.names = TRUE)) 7287 if(length(dotjava)) out$dotjava <- dotjava 7288 } 7289 7290 ## Check CITATION file for CRAN needs. 7291 .check_citation_for_CRAN <- function(cfile, meta) { 7292 ## For publishing on CRAN, we need to be able to correctly 7293 ## process package CITATION files without having the package 7294 ## installed (actually, using only the base and recommended 7295 ## packages), which we cannot perfectly emulate when checking. 7296 ## The best we can easily do is reduce the library search path 7297 ## to the system and site library. If the package is not 7298 ## installed there, check directly; otherwise, check for 7299 ## offending calls likely to cause trouble. 7300 ## Note however that in most cases, the issue is calling 7301 ## packageDescription() to get the package metadata, instead of 7302 ## using 'meta' as passed to readCitationFile() since R 2.8.0. 7303 ## Unfortunately, when the package is not installed, 7304 ## packageDescription() only warns and returns NA, or a vector 7305 ## of NAs if called with specific fields. Subscripting the 7306 ## return value using $ will fail (as this needs lists); 7307 ## subscripting by other means, or using specific fields, 7308 ## incorrectly results in NAs. 7309 ## The warnings are currently not caught by the direct check. 7310 ## (We could need a suitably package-not-found condition for 7311 ## reliable analysis: the condition messages are locale 7312 ## specific.) 7313 libpaths <- .libPaths() 7314 .libPaths(character()) 7315 on.exit(.libPaths(libpaths)) 7316 out <- list() 7317 installed <- nzchar(system.file(package = meta["Package"])) 7318 if(installed) { 7319 ## Ignore pre-2.8.0 compatibility calls to 7320 ## packageDescription() inside 7321 ## if(!exists("meta") || is.null(meta)) 7322 ccalls <- .parse_code_file(cfile, meta["Encoding"]) 7323 ind <- vapply(ccalls, 7324 function(e) { 7325 is.call(e) && 7326 (length(e) == 3L) && 7327 identical(deparse(e[[1L]]), "if") && 7328 identical(deparse(e[[2L]]), 7329 "!exists(\"meta\") || is.null(meta)") 7330 }, 7331 NA) 7332 if(any(ind)) 7333 ccalls <- ccalls[!ind] 7334 ccalls <- .find_calls(ccalls, recursive = TRUE) 7335 cnames <- 7336 intersect(unique(.call_names(ccalls)), 7337 c("packageDescription", "library", "require")) 7338 if(length(cnames)) 7339 out$citation_calls <- cnames 7340 cinfo <- 7341 .eval_with_capture(tryCatch(utils::readCitationFile(cfile, 7342 meta), 7343 error = identity))$value 7344 if(inherits(cinfo, "error")) { 7345 out$citation_error_reading_if_installed <- 7346 conditionMessage(cinfo) 7347 return(out) 7348 } 7349 } else { 7350 cinfo <- 7351 .eval_with_capture(tryCatch(utils::readCitationFile(cfile, 7352 meta), 7353 error = identity))$value 7354 if(inherits(cinfo, "error")) { 7355 out$citation_error_reading_if_not_installed <- 7356 conditionMessage(cinfo) 7357 return(out) 7358 } 7359 } 7360 ## If we can successfully read in the citation file, also check 7361 ## whether we can at least format the bibentries we obtained. 7362 cfmt <- tryCatch(format(cinfo, style = "text"), 7363 warning = identity, error = identity) 7364 ## This only finds unbalanced braces by default, with messages 7365 ## unexpected END_OF_INPUT ... { no } 7366 ## unexpected '}' ... } no { 7367 ## One can also find 'unknown Rd macros' by setting env var 7368 ## _R_UTILS_FORMAT_BIBENTRY_VIA_RD_PERMISSIVE_ to something 7369 ## true, and perhaps we should do this here. 7370 if(inherits(cfmt, "condition")) 7371 out$citation_problem_when_formatting <- 7372 conditionMessage(cfmt) 7373 out 7374 } 7375 7376 if(file.exists(cfile <- file.path(dir, "inst", "CITATION"))) { 7377 cinfo <- .check_citation_for_CRAN(cfile, meta) 7378 if(length(cinfo)) 7379 out[names(cinfo)] <- cinfo 7380 ## Simply 7381 ## out <- c(out, cinfo) 7382 ## strips the class attribute from out ... 7383 } 7384 7385 ## Check Authors@R. 7386 if(!is.na(aar <- meta["Authors@R"]) && 7387 ## DESCRIPTION is fully checked later on, so be careful. 7388 !inherits(aar <- tryCatch(str2expression(aar), error = identity), 7389 "error")) { 7390 bad <- ((length(aar) != 1L) || !is.call(aar <- aar[[1L]])) 7391 if(!bad) { 7392 cname <- as.character(aar[[1L]]) 7393 bad <- 7394 ((cname != "person") && 7395 ((cname != "c") || 7396 !all(vapply(aar[-1L], 7397 function(e) { 7398 (is.call(e) && 7399 (as.character(e[[1L]]) == "person")) 7400 }, 7401 FALSE)))) 7402 } 7403 if(bad) 7404 out$authors_at_R_calls <- aar 7405 else { 7406 ## Catch messages about deprecated arguments in person() calls. 7407 aar <- meta["Authors@R"] 7408 aut <- tryCatch(.eval_with_capture(utils:::.read_authors_at_R_field(aar)), 7409 error = identity) 7410 if(!inherits(aut, "error") && length(msg <- aut$message)) 7411 out$authors_at_R_message <- msg 7412 } 7413 } 7414 7415 ## Check Author field. 7416 auth <- trimws(as.vector(meta["Author"])) 7417 if(grepl("^Author *:", auth)) 7418 out$author_starts_with_Author <- TRUE 7419 if(grepl("^(Authors@R *:|person *\\(|c *\\()", auth)) 7420 out$author_should_be_authors_at_R <- auth 7421 7422 ## Check Title field. 7423 title <- trimws(as.vector(meta["Title"])) 7424 title <- gsub("[\n\t]", " ", title) 7425 package <- meta["Package"] 7426 if (tolower(title) == tolower(package)) { 7427 out$title_is_name <- TRUE 7428 } else { 7429 if(grepl(paste0("^", 7430 gsub(".", "[.]", package, fixed = TRUE), 7431 "[ :]"), title, ignore.case = TRUE)) 7432 out$title_includes_name <- TRUE 7433 language <- meta["Language"] 7434 if(is.na(language) || 7435 (language == "en") || 7436 startsWith(language, "en-")) { 7437 title2 <- toTitleCase(title) 7438 ## Keep single quoted elements unchanged. 7439 p <- "(^|(?<=[ \t[:punct:]]))'[^']*'($|(?=[ \t[:punct:]]))" 7440 m <- gregexpr(p, title, perl = TRUE) 7441 regmatches(title2, m) <- regmatches(title, m) 7442 if(title != title2) 7443 out$title_case <- c(title, title2) 7444 } 7445 } 7446 7447 ## Check Description field. 7448 descr <- trimws(as.vector(meta["Description"])) 7449 descr <- gsub("[\n\t]", " ", descr) 7450 package <- meta["Package"] 7451 if(grepl(paste0("^['\"]?", package), ignore.case = TRUE, descr)) 7452 out$descr_bad_start <- TRUE 7453 if(grepl("^(The|This|A|In this|In the) package", descr)) 7454 out$descr_bad_start <- TRUE 7455 if(!isTRUE(out$descr_bad_start) && !grepl("^['\"]?[[:upper:]]", descr)) 7456 out$descr_bad_initial <- TRUE 7457 descr <- strwrap(descr) 7458 if(any(ind <- grepl("(^|[^<])https?://", descr))) { 7459 ## Could try to filter out the matches for DOIs and arXiv ids 7460 ## noted differently below: not entirely straightforward when 7461 ## matching wrapped texts for to ease reporting ... 7462 out$descr_bad_URLs <- descr[ind] 7463 } 7464 if(any(ind <- grepl(paste(c("https?://.*doi.org/", 7465 "(^|[^<])doi:", 7466 "<doi[^:]", 7467 "<10[.]"), 7468 collapse = "|"), 7469 descr, ignore.case = TRUE))) 7470 out$descr_bad_DOIs <- descr[ind] 7471 if(any(ind <- grepl(paste(c("https?://arxiv.org", 7472 "(^|[^<])arxiv:", 7473 "<arxiv[^:]"), 7474 collapse = "|"), 7475 descr, ignore.case = TRUE))) 7476 out$descr_bad_arXiv_ids <- descr[ind] 7477 7478 skip_dates <- 7479 config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_DATES_", 7480 "FALSE")) 7481 7482 ## Check Date 7483 date <- trimws(as.vector(meta["Date"])) 7484 if(!is.na(date)) { 7485 dd <- strptime(date, "%Y-%m-%d", tz = "GMT") 7486 if (is.na(dd)) out$bad_date <- TRUE 7487 else if(!skip_dates && (as.Date(dd) < Sys.Date() - 31)) 7488 out$old_date <- TRUE 7489 } 7490 7491 ## Check build time stamp 7492 ptime <- trimws(as.vector(meta["Packaged"])) 7493 if(is.na(ptime)) { 7494 out$build_time_stamp_msg <- 7495 "The build time stamp is missing." 7496 } else { 7497 ts <- strptime(ptime, "%Y-%m-%d", tz = "GMT") 7498 if(is.na(ts)) { 7499 out$build_time_stamp_msg <- 7500 "The build time stamp has invalid/outdated format." 7501 } 7502 else if(!skip_dates && (as.Date(ts) < Sys.Date() - 31)) { 7503 out$build_time_stamp_msg <- 7504 "This build time stamp is over a month old." 7505 } 7506 } 7507 7508 ## Check DESCRIPTION placeholders 7509 placeholders <- 7510 c(if(!is.na(x <- tolower(meta["Title"])) && 7511 startsWith(x, "what the package does")) 7512 x, 7513 if(!is.na(x <- meta["Author"]) && 7514 (x == "Who wrote it")) 7515 x, 7516 if(!is.na(x <- meta["Maintainer"]) && 7517 (startsWith(x, "Who to complain to") || 7518 startsWith(x, "The package maintainer"))) 7519 x, 7520 if(!is.na(x <- tolower(meta["Description"])) && 7521 (startsWith(x, "what the package does") || 7522 startsWith(x, "more about what it does"))) 7523 x) 7524 if(length(placeholders)) 7525 out$placeholders <- placeholders 7526 7527 ## Are there non-ASCII characters in the R source code without a 7528 ## package encoding in DESCRIPTION? 7529 ## Note that checking always runs .check_package_ASCII_code() which 7530 ## however ignores comments. Ideally, the checks would be merged, 7531 ## with the comment checking suitably conditionalized. 7532 ## Note also that this does not catch the cases where non-ASCII 7533 ## content in R source code cannot be re-encoded using a given 7534 ## package encoding. Ideally, this would be checked for as well. 7535 if(is.na(meta["Encoding"]) && dir.exists(file.path(dir, "R"))) { 7536 ## A variation on showNonASCII(): 7537 find_non_ASCII_lines <- function(f) { 7538 x <- readLines(f, warn = FALSE) 7539 asc <- iconv(x, "latin1", "ASCII") 7540 ind <- is.na(asc) | asc != x 7541 if(any(ind)) { 7542 paste0(which(ind), 7543 ": ", 7544 iconv(x[ind], "latin1", "ASCII", sub = "byte")) 7545 } else character() 7546 } 7547 OS_subdirs <- c("unix", "windows") 7548 code_files <- list_files_with_type(file.path(dir, "R"), 7549 "code", 7550 OS_subdirs = OS_subdirs) 7551 names(code_files) <- .file_path_relative_to_dir(code_files, dir) 7552 lines <- Filter(length, lapply(code_files, find_non_ASCII_lines)) 7553 if(length(lines)) 7554 out$R_files_non_ASCII <- lines 7555 } 7556 7557 if(file.exists(fp <- file.path(dir, "R", 7558 paste0(basename(dir), 7559 "-internal.R")))) { 7560 exprs <- parse(fp) 7561 tst <- function(e) { 7562 is.call(e) && 7563 (length(s <- as.character(e[[1L]])) == 1L) && 7564 (s == "<-") && 7565 (length(s <- as.character(e[[2L]])) == 1L) && 7566 (s == ".Random.seed") 7567 } 7568 if(any(vapply(exprs, tst, NA))) 7569 out$R_files_set_random_seed <- basename(fp) 7570 } 7571 7572 if(!is.na(size <- as.numeric(pkgSize)) && 7573 size > as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_TARBALL_THRESHOLD_", 7574 unset = "5e6"))) 7575 out$size_of_tarball <- size 7576 7577 ## Check URLs. 7578 remote <- 7579 (!localOnly && 7580 !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_URL_CHECKS_IF_REMOTE_", 7581 "FALSE"))) 7582 check_urls_in_parallel <- 7583 config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_CHECK_URLS_IN_PARALLEL_", 7584 "FALSE")) 7585 if(!capabilities("libcurl") && remote) 7586 out$no_url_checks <- TRUE 7587 else { 7588 udb <- url_db_from_package_sources(dir) 7589 bad <- tryCatch(check_url_db(udb, 7590 remote = remote, 7591 parallel = check_urls_in_parallel), 7592 error = identity) 7593 if(inherits(bad, "error")) { 7594 out$bad_urls <- bad 7595 } else if(NROW(bad)) { 7596 ## When checking a new submission, take the canonical CRAN 7597 ## package URL as ok, and signal variants using http instead 7598 ## of https as non-canonical instead of showing "not found". 7599 prefix <- "https://cran.r-project.org/package=" 7600 ncp <- nchar(prefix) 7601 ind <- ((substring(tolower(bad$URL), 1L, ncp) == prefix) & 7602 (substring(bad$URL, ncp + 1L) == package)) 7603 if(any(ind)) 7604 bad <- bad[!ind, ] 7605 prefix <- "http://cran.r-project.org/package=" 7606 ncp <- nchar(prefix) 7607 ind <- ((substring(tolower(bad$URL), 1L, ncp) == prefix) & 7608 (substring(bad$URL, ncp + 1L) == package)) 7609 if(any(ind)) 7610 bad[ind, c("Status", "Message")] <- "" 7611 if(NROW(bad)) 7612 out$bad_urls <- bad 7613 } 7614 if(config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_CHECK_FILE_URIS_", 7615 "FALSE"))) { 7616 ## Also check file URIs in packages. 7617 ## These only make sense relative to their parent. 7618 ## We could integrate this check into check_url_db() by e.g. 7619 ## passing the top-level package dir via a suitable env var, 7620 ## but this is not quite straightforward as the check code 7621 ## aggregates parents according to URI. 7622 urls <- udb$URL 7623 parts <- parse_URI_reference(urls) 7624 ind <- (parts[, "scheme"] %in% c("", "file")) 7625 fpaths1 <- fpaths0 <- parts[ind, "path"] 7626 parents <- udb[ind, "Parent"] 7627 ## Help files, vignettes (and more) can be accessed via the 7628 ## dynamic HTML help system. This employs an internal HTTP 7629 ## server which handles 7630 ## /doc/html /demo /library 7631 ## and relative paths from help system components resolving 7632 ## to such. 7633 ## (Note that these will not work in general, e.g. for the 7634 ## pdf refmans.) 7635 if(any(ind <- (startsWith(fpaths0, "../") & 7636 grepl("^(inst/doc|man|demo)", parents)))) { 7637 ## Vignettes have document root 7638 ## /library/<pkg>/doc 7639 ## Help pages have 7640 ## /library/<pkg>/html 7641 foo <- rep.int("/library/<pkg>/<sub>", sum(ind)) 7642 bar <- fpaths0[ind] 7643 while(length(pos <- which(startsWith(bar, "../")))) { 7644 foo[pos] <- dirname(foo[pos]) 7645 bar[pos] <- substring(bar[pos], 4L) 7646 } 7647 fpaths1[ind] <- foo 7648 } 7649 fpaths1[grepl("^(/doc/html|/demo|/library)", fpaths1)] <- "" 7650 fpaths1[(fpaths1 == "index.html") & 7651 startsWith(parents, "inst/doc")] <- "" 7652 ## (Of course, one could verify that the special cased paths 7653 ## really exist.) 7654 ppaths <- dirname(parents) 7655 pos <- which(!file.exists(file.path(ifelse(nzchar(ppaths), 7656 file.path(dir, 7657 ppaths), 7658 dir), 7659 fpaths1))) 7660 if(length(pos)) 7661 out$bad_file_URIs <- 7662 cbind(fpaths0[pos], parents[pos]) 7663 } 7664 if(remote) { 7665 ## Also check arXiv ids. 7666 pat <- "<(arXiv:)([[:alnum:]/.-]+)([[:space:]]*\\[[^]]+\\])?>" 7667 dsc <- meta["Description"] 7668 ids <- .gregexec_at_pos(pat, dsc, gregexpr(pat, dsc), 3L) 7669 if(length(ids)) { 7670 ini <- "https://arxiv.org/abs/" 7671 udb <- url_db(paste0(ini, ids), 7672 rep.int("DESCRIPTION", length(ids))) 7673 bad <- tryCatch(check_url_db(udb, 7674 parallel = 7675 check_urls_in_parallel), 7676 error = identity) 7677 if(!inherits(bad, "error") && length(bad)) 7678 out$bad_arXiv_ids <- 7679 substring(bad$URL, nchar(ini) + 1L) 7680 } 7681 ## Also check ORCID iDs. 7682 odb <- .ORCID_iD_db_from_package_sources(dir) 7683 if(NROW(odb)) { 7684 ## Only look at things that may be valid: the others are 7685 ## complained about elsewhere. 7686 ind <- grepl(.ORCID_iD_variants_regexp, odb[, 1L]) 7687 odb <- odb[ind, , drop = FALSE] 7688 } 7689 if(NROW(odb)) { 7690 ids <- sub(.ORCID_iD_variants_regexp, "\\3", odb[, 1L]) 7691 ini <- "https://orcid.org/" 7692 udb <- url_db(paste0(ini, ids), odb[, 2L]) 7693 bad <- tryCatch(check_url_db(udb, 7694 parallel = 7695 check_urls_in_parallel), 7696 error = identity) 7697 if(!inherits(bad, "error") && length(bad)) 7698 out$bad_ORCID_iDs <- 7699 cbind(substring(bad$URL, nchar(ini) + 1L), 7700 bad[, 2L]) 7701 } 7702 } 7703 } 7704 7705 ## Checks from here down require Internet access, so drop out now if we 7706 ## don't want that. 7707 if (localOnly) 7708 return(out) 7709 7710 urls <- .get_standard_repository_URLs() 7711 7712 ## If a package has a FOSS license, check whether any of its strong 7713 ## recursive dependencies restricts use. 7714 if(!localOnly && foss) { 7715 available <- 7716 utils::available.packages(utils::contrib.url(urls, "source"), 7717 filters = c("R_version", "duplicates")) 7718 ## We need the current dependencies of the package (so batch 7719 ## upload checks will not necessarily do "the right thing"). 7720 package <- meta["Package"] 7721 depends <- c("Depends", "Imports", "LinkingTo") 7722 ## Need to be careful when merging the dependencies of the 7723 ## package (in case it is not yet available). 7724 if(package %in% rownames(available)) { 7725 available[package, depends] <- meta[depends] 7726 } else { 7727 entry <- rbind(meta[colnames(available)]) 7728 rownames(entry) <- package 7729 available <- rbind(available, entry) 7730 } 7731 ldb <- analyze_licenses(available[, "License"], available) 7732 depends <- unlist(package_dependencies(package, available, 7733 recursive = TRUE)) 7734 ru <- ldb$restricts_use 7735 pnames_restricts_use_TRUE <- rownames(available)[!is.na(ru) & ru] 7736 pnames_restricts_use_NA <- rownames(available)[is.na(ru)] 7737 bad <- intersect(depends, pnames_restricts_use_TRUE) 7738 if(length(bad)) 7739 out$depends_with_restricts_use_TRUE <- bad 7740 bad <- intersect(depends, pnames_restricts_use_NA) 7741 if(length(bad)) 7742 out$depends_with_restricts_use_NA <- bad 7743 bv <- parse_description_field(meta, "BuildVignettes", TRUE) 7744 if (!bv) out$foss_with_BuildVignettes <- TRUE 7745 } 7746 7747 ## We do not want to use utils::available.packages() for now, as 7748 ## this unconditionally filters according to R version and OS type. 7749 ## <FIXME> 7750 ## This is no longer true ... 7751 ## </FIXME> 7752 .repository_db <- function(u) { 7753 con <- gzcon(url(sprintf("%s/src/contrib/PACKAGES.gz", u), "rb")) 7754 on.exit(close(con)) 7755 ## hopefully all these fields are ASCII, or we need to re-encode. 7756 cbind(read.dcf(con, 7757 c(.get_standard_repository_db_fields(), "Path")), 7758 Repository = u) 7759 7760 } 7761 db <- tryCatch(lapply(urls, .repository_db), error = identity) 7762 if(inherits(db, "error")) { 7763 message("NB: need Internet access to use CRAN incoming checks") 7764 ## Actually, all repositories could be local file:// mirrors. 7765 return(out) 7766 } 7767 db <- do.call(rbind, db) 7768 7769 ## Note that .get_standard_repository_URLs() puts the CRAN master first. 7770 CRAN <- urls[1L] 7771 7772 ## Check for CRAN repository db overrides and possible conflicts. 7773 con <- url(sprintf("%s/src/contrib/PACKAGES.in", CRAN)) 7774 odb <- read.dcf(con) 7775 close(con) 7776 ## For now (2012-11-28), PACKAGES.in is all ASCII, so there is no 7777 ## need to re-encode. Eventually, it might be in UTF-8 ... 7778 entry <- odb[odb[, "Package"] == meta["Package"], ] 7779 entry <- entry[!is.na(entry) & 7780 (names(entry) %notin% c("Package", "X-CRAN-History"))] 7781 if(length(entry)) { 7782 ## Check for conflicts between package license implications and 7783 ## repository overrides. Note that the license info predicates 7784 ## are logicals (TRUE, NA or FALSE) and the repository overrides 7785 ## are character ("yes", missing or "no"). 7786 if(!is.na(iif <- lic_info$is_FOSS) && 7787 !is.na(lif <- entry["License_is_FOSS"]) && 7788 ((lif == "yes") != iif)) 7789 out$conflict_in_license_is_FOSS <- lif 7790 if(!is.na(iru <- lic_info$restricts_use) && 7791 !is.na(lru <- entry["License_restricts_use"]) && 7792 ((lru == "yes") != iru)) 7793 out$conflict_in_license_restricts_use <- lru 7794 7795 fmt <- function(s) 7796 unlist(lapply(s, 7797 function(e) { 7798 paste(strwrap(e, indent = 2L, exdent = 4L), 7799 collapse = "\n") 7800 })) 7801 nms <- names(entry) 7802 ## Report all overrides for visual inspection. 7803 entry <- fmt(sprintf(" %s: %s", nms, entry)) 7804 names(entry) <- nms 7805 out$overrides <- entry 7806 fields <- intersect(names(meta), nms) 7807 if(length(fields)) { 7808 ## Find fields where package metadata and repository 7809 ## overrides are in conflict. 7810 ind <- ! unlist(Map(identical, 7811 fmt(sprintf(" %s: %s", fields, meta[fields])), 7812 entry[fields])) 7813 if(any(ind)) 7814 out$conflicts <- fields[ind] 7815 } 7816 } 7817 7818 archive_db <- CRAN_archive_db() 7819 packages_in_CRAN_archive <- names(archive_db) 7820 7821 ## Package names must be unique within standard repositories when 7822 ## ignoring case. 7823 package <- meta["Package"] 7824 packages <- db[, "Package"] 7825 if(package %notin% packages) out$new_submission <- TRUE 7826 clashes <- character() 7827 pos <- which((tolower(packages) == tolower(package)) & 7828 (packages != package)) 7829 if(length(pos)) 7830 clashes <- 7831 sprintf("%s [%s]", packages[pos], db[pos, "Repository"]) 7832 ## If possible, also catch clashes with archived CRAN packages 7833 ## (which might get un-archived eventually). 7834 if(length(packages_in_CRAN_archive)) { 7835 pos <- which((tolower(packages_in_CRAN_archive) == 7836 tolower(package)) & 7837 (packages_in_CRAN_archive != package)) 7838 if(length(pos)) { 7839 clashes <- 7840 c(clashes, 7841 sprintf("%s [CRAN archive]", 7842 packages_in_CRAN_archive[pos])) 7843 } 7844 } 7845 if(length(clashes)) 7846 out$bad_package <- list(package, clashes) 7847 7848 ## Is this duplicated from another repository? 7849 repositories <- db[(packages == package) & 7850 (db[, "Repository"] != CRAN), 7851 "Repository"] 7852 if(length(repositories)) 7853 out$repositories <- repositories 7854 7855 ## Does this have strong dependencies not in mainstream 7856 ## repositories? This should not happen, and hence is not compared 7857 ## against possibly given additional repositories. 7858 strong_dependencies <- 7859 setdiff(unique(c(.extract_dependency_package_names(meta["Depends"]), 7860 .extract_dependency_package_names(meta["Imports"]), 7861 .extract_dependency_package_names(meta["LinkingTo"]))), 7862 c(.get_standard_package_names()$base, db[, "Package"])) 7863 if(length(strong_dependencies)) { 7864 out$strong_dependencies_not_in_mainstream_repositories <- 7865 strong_dependencies 7866 } 7867 7868 ## Does this have Suggests or Enhances not in mainstream 7869 ## repositories? 7870 suggests_or_enhances <- 7871 setdiff(unique(c(.extract_dependency_package_names(meta["Suggests"]), 7872 .extract_dependency_package_names(meta["Enhances"]))), 7873 c(.get_standard_package_names()$base, db[, "Package"])) 7874 if(length(suggests_or_enhances)) { 7875 out$suggests_or_enhances_not_in_mainstream_repositories <- 7876 suggests_or_enhances 7877 } 7878 if(!is.na(aurls <- meta["Additional_repositories"])) { 7879 aurls <- .read_additional_repositories_field(aurls) 7880 ## Get available packages separately for each given URL, so that 7881 ## we can spot the ones which do not provide any packages. 7882 adb <- 7883 tryCatch(lapply(aurls, 7884 function(u) { 7885 utils::available.packages(utils::contrib.url(u, 7886 "source"), 7887 filters = 7888 c("R_version", 7889 "duplicates")) 7890 }), 7891 error = identity) 7892 if(inherits(adb, "error")) { 7893 out$additional_repositories_analysis_failed_with <- 7894 conditionMessage(adb) 7895 } else { 7896 ## Check for additional repositories with no packages. 7897 ind <- vapply(adb, NROW, 0L) == 0L 7898 if(any(ind)) 7899 out$additional_repositories_with_no_packages <- 7900 aurls[ind] 7901 ## Merge available packages dbs and remove duplicates. 7902 adb <- do.call(rbind, adb) 7903 adb <- utils:::available_packages_filters_db$duplicates(adb) 7904 ## Ready. 7905 dependencies <- unique(c(strong_dependencies, suggests_or_enhances)) 7906 pos <- match(dependencies, rownames(adb), nomatch = 0L) 7907 ind <- (pos > 0L) 7908 tab <- matrix(character(), nrow = 0L, ncol = 3L) 7909 if(any(ind)) 7910 tab <- rbind(tab, 7911 cbind(dependencies[ind], 7912 "yes", 7913 adb[pos[ind], "Repository"])) 7914 ind <- !ind 7915 if(any(ind)) 7916 tab <- rbind(tab, 7917 cbind(dependencies[ind], 7918 "no", 7919 "?")) 7920 ## Map Repository fields to URLs, and determine unused 7921 ## URLs. 7922 ## Note that available.packages() possibly adds Path 7923 ## information in the Repository field, so matching 7924 ## given contrib URLs to these fields is not trivial. 7925 unused <- character() 7926 for(u in aurls) { 7927 cu <- utils::contrib.url(u, "source") 7928 ind <- startsWith(tab[, 3L], cu) 7929 if(any(ind)) { 7930 tab[ind, 3L] <- u 7931 } else { 7932 unused <- c(unused, u) 7933 } 7934 } 7935 if(length(unused)) 7936 tab <- rbind(tab, cbind("?", "?", unused)) 7937 dimnames(tab) <- NULL 7938 out$additional_repositories_analysis_results <- tab 7939 } 7940 } 7941 7942 ## Check DOIs. 7943 if(capabilities("libcurl") && 7944 !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_DOI_CHECKS_", 7945 "FALSE"))) { 7946 bad <- tryCatch(check_doi_db(doi_db_from_package_sources(dir), 7947 parallel = check_urls_in_parallel), 7948 error = identity) 7949 if(inherits(bad, "error") || NROW(bad)) 7950 out$bad_dois <- bad 7951 } 7952 7953 ## Is this an update for a package already on CRAN? 7954 db <- db[(packages == package) & 7955 (db[, "Repository"] == CRAN) & 7956 is.na(db[, "Path"]), , drop = FALSE] 7957 ## This drops packages in version-specific subdirectories. 7958 ## It also does not know about archived versions. 7959 if(!NROW(db)) { 7960 if(package %in% packages_in_CRAN_archive) { 7961 out$CRAN_archive <- TRUE 7962 v_m <- package_version(meta["Version"]) 7963 v_a <- sub("^.*_(.*)\\.tar.gz$", "\\1", 7964 basename(rownames(archive_db[[package]]))) 7965 v_a <- max(package_version(v_a, strict = FALSE), 7966 na.rm = TRUE) 7967 if(v_m <= v_a) 7968 out$bad_version <- list(v_m, v_a) 7969 } 7970 if(!foss) 7971 out$bad_license <- meta["License"] 7972 return(out) 7973 } 7974 7975 ## Checks from this point down should be for a package already on CRAN 7976 7977 ## For now, there should be no duplicates ... 7978 7979 ## Package versions should be newer than what we already have on CRAN. 7980 7981 v_m <- package_version(meta["Version"]) 7982 v_d <- max(package_version(db[, "Version"])) 7983 if((v_m <= v_d) && 7984 !config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_SKIP_VERSIONS_", 7985 "FALSE"))) 7986 out$bad_version <- list(v_m, v_d) 7987 if((v_m$major == v_d$major) && (v_m$minor >= v_d$minor + 10)) 7988 out$version_with_jump_in_minor <- list(v_m, v_d) 7989 7990 ## Check submission recency and frequency. 7991 current_db <- CRAN_current_db() 7992 mtimes <- c(current_db[match(package, 7993 sub("_.*", "", rownames(current_db)), 7994 nomatch = 0L), 7995 "mtime"], 7996 archive_db[[package]]$mtime) 7997 if(length(mtimes)) { 7998 deltas <- Sys.Date() - as.Date(sort(mtimes, decreasing = TRUE)) 7999 ## Number of days since last update. 8000 recency <- as.numeric(deltas[1L]) 8001 if(recency < 7) 8002 out$recency <- recency 8003 ## Number of updates in past 6 months. 8004 frequency <- sum(deltas <= 180) 8005 if(frequency > 6) 8006 out$frequency <- frequency 8007 } 8008 8009 ## Watch out for maintainer changes. 8010 ## Note that we cannot get the maintainer info from the PACKAGES 8011 ## files. 8012 db <- tryCatch(CRAN_package_db(), error = identity) 8013 if(inherits(db, "error")) return(out) 8014 8015 meta1 <- db[db[, "Package"] == package, ] 8016 ## this can have multiple entries, e.g. for recommended packages. 8017 meta0 <- unlist(meta1[1L, ]) 8018 m_m <- as.vector(meta["Maintainer"]) # drop name 8019 m_d <- meta0["Maintainer"] 8020 # There may be white space differences here 8021 m_m_1 <- gsub("[[:space:]]+", " ", m_m) 8022 m_d_1 <- gsub("[[:space:]]+", " ", m_d) 8023 if(!all(m_m_1 == m_d_1)) { 8024 ## strwrap is used below, so we need to worry about encodings. 8025 ## m_d is in UTF-8 already 8026 if(Encoding(m_m) == "latin1") m_m <- iconv(m_m, "latin1") 8027 out$new_maintainer <- list(m_m, m_d) 8028 } 8029 8030 l_d <- meta0["License"] 8031 if(!foss && analyze_license(l_d)$is_verified) 8032 out$new_license <- list(meta["License"], l_d) 8033 8034 ## for incoming check we may want to check for GNU make in SystemRequirements here 8035 ## in order to auto-accept packages once this was already accepted before 8036 if(config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_NOTE_GNU_MAKE_", 8037 "FALSE"))){ 8038 SysReq <- meta["SystemRequirements"] 8039 if(!is.na(SysReq) && grepl("GNU [Mm]ake", SysReq)) { 8040 out$GNUmake <- TRUE 8041 } 8042 } 8043 8044 ## Re-check for some notes if enabled and current version was published recently enough. 8045 if(!inherits(year <- tryCatch(format(as.Date(meta0["Published"]), "%Y"), 8046 error = identity), 8047 "error")){ 8048 ## possible mis-spellings and keep only the new ones: 8049 if(NROW(a <- out$spelling) 8050 && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_ASPELL_RECHECK_MAYBE_", 8051 "TRUE")) 8052 && (year >= 8053 as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_ASPELL_RECHECK_START_", 8054 "2013")))) { 8055 a0 <- .aspell_package_description_for_CRAN(meta = meta0) 8056 out$spelling <- a[a$Original %notin% a0$Original, ] 8057 } 8058 8059 # possible title_includes_name and only report if the title actually changed 8060 if(NROW(out$title_includes_name) 8061 && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_INCLUDES_NAME_RECHECK_MAYBE_", 8062 "TRUE")) 8063 && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_INCLUDES_NAME_RECHECK_START_", 8064 "2016"))) 8065 && meta0["Title"] == meta["Title"]) { 8066 out$title_includes_name <- NULL 8067 } 8068 8069 # possible title case problems and only report if the title actually changed 8070 if(NROW(out$title_case) 8071 && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_CASE_RECHECK_MAYBE_", 8072 "TRUE")) 8073 && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_TITLE_CASE_RECHECK_START_", 8074 "2016"))) 8075 && meta0["Title"] == meta["Title"]) { 8076 out$title_case <- NULL 8077 } 8078 8079 # possible bad Description start and only report if new: 8080 if(NROW(out$descr_bad_start) 8081 && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_DESCR_BAD_START_RECHECK_MAYBE_", 8082 "TRUE")) 8083 && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_DESCR_BAD_START_RECHECK_START_", 8084 "2016")))) { 8085 descr0 <- trimws(as.vector(meta0["Description"])) 8086 descr0 <- gsub("[\n\t]", " ", descr0) 8087 if(grepl(paste0("^['\"]?", package), ignore.case = TRUE, descr0) 8088 || grepl("^(The|This|A|In this|In the) package", descr0)){ 8089 out$descr_bad_start <- NULL 8090 } 8091 } 8092 8093 # possible GNU make usage and only report if this is new 8094 if(NROW(out$GNUmake) 8095 && config_val_to_logical(Sys.getenv("_R_CHECK_CRAN_INCOMING_GNU_MAKE_RECHECK_MAYBE_", 8096 "TRUE")) 8097 && (year >= as.numeric(Sys.getenv("_R_CHECK_CRAN_INCOMING_GNU_MAKE_RECHECK_START_", 8098 "2015")))) { 8099 SysReq0 <- meta0["SystemRequirements"] 8100 if(!is.na(SysReq0) && grepl("GNU [Mm]ake", SysReq0)) { 8101 out$GNUmake <- NULL 8102 } 8103 } 8104 } 8105 8106 out 8107} 8108 8109format.check_package_CRAN_incoming <- 8110function(x, ...) 8111{ 8112 fmt <- function(x) { 8113 if(length(x)) paste(x, collapse = "\n") else character() 8114 } 8115 8116 c(character(), 8117 if(length(x$Maintainer)) 8118 sprintf("Maintainer: %s", sQuote(lines2str(x$Maintainer, " "))) 8119 else 8120 "No maintainer field in DESCRIPTION file", 8121 fmt(c(if(isTRUE(x$Maintainer_invalid_or_multi_person)) 8122 "The maintainer field is invalid or specifies more than one person", 8123 if(isTRUE(x$empty_Maintainer_name)) 8124 'The maintainer field lacks a name', 8125 if(isTRUE(x$Maintainer_needs_quotes)) 8126 'The display-name part of the maintainer field should be enclosed in ""') 8127 ), 8128 if(length(x$new_submission)) 8129 "New submission", 8130 if(length(y <- x$bad_package)) 8131 sprintf("Conflicting package names (submitted: %s, existing: %s)", 8132 y[[1L]], y[[2L]]), 8133 if(length(y <- x$repositories)) 8134 sprintf("Package duplicated from %s", y), 8135 if(length(y <- x$CRAN_archive)) 8136 "Package was archived on CRAN", 8137 fmt(c(if(length(y <- x$bad_version)) 8138 sprintf("Insufficient package version (submitted: %s, existing: %s)", 8139 y[[1L]], y[[2L]]), 8140 if(length(y <- x$version_with_leading_zeroes)) 8141 sprintf("Version contains leading zeroes (%s)", y), 8142 if(length(y <- x$version_with_large_components)) 8143 sprintf("Version contains large components (%s)", y), 8144 if(length(y <- x$version_with_jump_in_minor)) 8145 sprintf("Version jumps in minor (submitted: %s, existing: %s)", 8146 y[[1L]], y[[2L]]))), 8147 fmt(c(if(length(y <- x$recency)) 8148 sprintf("Days since last update: %d", y), 8149 if(length(y <- x$frequency)) 8150 sprintf("Number of updates in past 6 months: %d", y))), 8151 if(length(y <- x$new_maintainer)) 8152 paste(c("New maintainer:", 8153 strwrap(y[[1L]], indent = 2L, exdent = 4L), 8154 "Old maintainer(s):", 8155 strwrap(y[[2L]], indent = 2L, exdent = 4L)), 8156 collapse = "\n"), 8157 fmt(c(if(length(y <- x$bad_license)) 8158 sprintf("Non-FOSS package license (%s)", y), 8159 if(length(y <- x$new_license)) 8160 paste(c("Change to non-FOSS package license.", 8161 "New license:", 8162 strwrap(y[[1L]], indent = 2L, exdent = 4L), 8163 "Old license:", 8164 strwrap(y[[2L]], indent = 2L, exdent = 4L)), 8165 collapse = "\n"), 8166 if(length(y <- x$extensions)) { 8167 paste(c("License components with restrictions and base license permitting such:", 8168 paste0(" ", y), 8169 unlist(lapply(x$pointers, 8170 function(e) { 8171 c(sprintf("File '%s':", e[1L]), 8172 paste0(" ", e[-1L])) 8173 }))), 8174 collapse = "\n") 8175 })), 8176 if(NROW(y <- x$spelling)) { 8177 s <- split(sprintf("%d:%d", y$Line, y$Column), y$Original) 8178 paste(c("Possibly mis-spelled words in DESCRIPTION:", 8179 sprintf(" %s (%s)", 8180 names(s), 8181 lapply(s, paste, collapse = ", "))), 8182 collapse = "\n") 8183 }, 8184 if(isTRUE(x$foss_with_BuildVignettes)) { 8185 "FOSS licence with BuildVignettes: false" 8186 }, 8187 if(length(y <- x$fields)) { 8188 paste(c("Unknown, possibly mis-spelled, fields in DESCRIPTION:", 8189 sprintf(" %s", paste(sQuote(y), collapse = " "))), 8190 collapse = "\n") 8191 }, 8192 fmt(c(if(length(y <- x$overrides)) { 8193 paste(c("CRAN repository db overrides:", y), 8194 collapse = "\n") 8195 }, 8196 if(length(y <- x$conflicts)) { 8197 paste(sprintf("CRAN repository db conflicts: %s", 8198 sQuote(y)), 8199 collapse = "\n") 8200 }, 8201 if(length(y <- x$conflict_in_license_is_FOSS)) { 8202 sprintf("Package license conflicts with %s override", 8203 sQuote(paste("License_is_FOSS:", y))) 8204 }, 8205 if(length(y <- x$conflict_in_license_restricts_use)) { 8206 sprintf("Package license conflicts with %s override", 8207 sQuote(paste("License_restricts_use:", y))) 8208 })), 8209 fmt(c(if(length(y <- x$depends_with_restricts_use_TRUE)) { 8210 paste(c("Package has a FOSS license but eventually depends on the following", 8211 if(length(y) > 1L) 8212 "packages which restrict use:" 8213 else 8214 "package which restricts use:", 8215 strwrap(paste(y, collapse = ", "), 8216 indent = 2L, exdent = 4L)), 8217 collapse = "\n") 8218 }, 8219 if(length(y <- x$depends_with_restricts_use_NA)) { 8220 paste(c("Package has a FOSS license but eventually depends on the following", 8221 if(length(y) > 1L) 8222 "packages which may restrict use:" 8223 else 8224 "package which may restrict use:", 8225 strwrap(paste(y, collapse = ", "), 8226 indent = 2L, exdent = 4L)), 8227 collapse = "\n") 8228 })), 8229 fmt(c(if(length(y <- x$strong_dependencies_not_in_mainstream_repositories)) { 8230 paste(c("Strong dependencies not in mainstream repositories:", 8231 strwrap(paste(y, collapse = ", "), 8232 indent = 2L, exdent = 4L)), 8233 collapse = "\n") 8234 }, 8235 if(length(y <- x$suggests_or_enhances_not_in_mainstream_repositories)) { 8236 paste(c("Suggests or Enhances not in mainstream repositories:", 8237 strwrap(paste(y, collapse = ", "), 8238 indent = 2L, exdent = 4L)), 8239 collapse = "\n") 8240 }, 8241 if(length(y <- x$additional_repositories_analysis_failed_with)) { 8242 paste(c("Using Additional_repositories specification failed with:", 8243 paste0(" ", y)), 8244 collapse = "\n") 8245 }, 8246 if(length(y <- x$additional_repositories_analysis_results)) { 8247 paste(c("Availability using Additional_repositories specification:", 8248 sprintf(" %s %s %s", 8249 format(y[, 1L], justify = "left"), 8250 format(y[, 2L], justify = "right"), 8251 format(y[, 3L], justify = "left"))), 8252 collapse = "\n") 8253 }, 8254 if(length(y <- x$additional_repositories_with_no_packages)) { 8255 paste(c("Additional repositories with no packages:", 8256 paste0(" ", y)), 8257 collapse = "\n") 8258 })), 8259 if(length(y <- x$uses)) { 8260 paste(if(length(y) > 1L) 8261 "Uses the superseded packages:" else 8262 "Uses the superseded package:", 8263 paste(sQuote(y), collapse = ", ")) 8264 }, 8265 if(length(y <- x$BUGS)) { 8266 paste(if(length(y) > 1L) 8267 "Uses the non-portable packages:" else 8268 "Uses the non-portable package:", 8269 paste(sQuote(y), collapse = ", ")) 8270 }, 8271 if(length(y <- x$authors_at_R_calls)) { 8272 "Authors@R field should be a call to person(), or combine such calls." 8273 }, 8274 if(length(y <- x$authors_at_R_message)) { 8275 paste(c("Authors@R field gives persons with deprecated elements:", 8276 paste0(" ", y)), 8277 collapse = "\n") 8278 }, 8279 if(length(y <- x$author_starts_with_Author)) { 8280 "Author field starts with 'Author:'." 8281 }, 8282 if(length(y <- x$author_should_be_authors_at_R)) { 8283 paste(c("Author field should be Authors@R. Current value is:", 8284 paste0(" ", gsub("\n", "\n ", y, fixed=TRUE))), 8285 collapse = "\n") 8286 }, 8287 if(length(y <- x$vignette_sources_only_in_inst_doc)) { 8288 if(isFALSE(x$have_vignettes_dir)) 8289 paste(c("Vignette sources in 'inst/doc' with no 'vignettes' directory:", 8290 strwrap(paste(sQuote(y), collapse = ", "), 8291 indent = 2L, exdent = 2L), 8292 "A 'vignettes' directory is required as from R 3.1.0"), 8293 collapse = "\n") 8294 else 8295 paste(c("Vignette sources in 'inst/doc' missing from the 'vignettes' directory:", 8296 strwrap(paste(sQuote(y), collapse = ", "), 8297 indent = 2L, exdent = 2L)), 8298 collapse = "\n") 8299 }, 8300 if(length(y <- x$missing_vignette_index)) { 8301 "Package has a VignetteBuilder field but no prebuilt vignette index." 8302 }, 8303 fmt(c(if(length(y <- x$missing_manual_rdb)) { 8304 "Package has help file(s) containing build-stage \\Sexpr{} expressions but no 'build/partial.rdb' file." 8305 }, 8306 if(length(y <- x$missing_manual_pdf)) { 8307 "Package has help file(s) containing install/render-stage \\Sexpr{} expressions but no prebuilt PDF manual." 8308 })), 8309 fmt(c(if(length(y <- x$dotjava)) { 8310 "Package installs .java files." 8311 }, 8312 if(length(y <- x$javafiles)) { 8313 "Package has FOSS license, installs .class/.jar but has no 'java' directory." 8314 })), 8315 fmt(c(if(length(y <- x$citation_calls)) { 8316 paste(c("Package CITATION file contains call(s) to:", 8317 strwrap(paste(y, collapse = ", "), 8318 indent = 2L, exdent = 4L)), 8319 collapse = "\n") 8320 }, 8321 if(length(y <- x$citation_error_reading_if_installed)) { 8322 paste(c("Reading CITATION file fails with", 8323 paste0(" ", y)), 8324 collapse = "\n") 8325 }, 8326 if(length(y <- x$citation_error_reading_if_not_installed)) { 8327 paste(c("Reading CITATION file fails with", 8328 paste0(" ", y), 8329 "when package is not installed."), 8330 collapse = "\n") 8331 }, 8332 if(length(y <- x$citation_problem_when_formatting)) { 8333 paste(c("Problems when formatting CITATION entries:", 8334 paste0(" ", y)), 8335 collapse = "\n") 8336 })), 8337 fmt(c(if(length(y <- x$bad_urls)) { 8338 if(inherits(y, "error")) 8339 paste(c("Checking URLs failed with message:", 8340 conditionMessage(y)), 8341 collapse = "\n") 8342 else 8343 paste(c(if(length(y) > 1L) 8344 "Found the following (possibly) invalid URLs:" 8345 else 8346 "Found the following (possibly) invalid URL:", 8347 paste0(" ", gsub("\n", "\n ", format(y), fixed=TRUE))), 8348 collapse = "\n") 8349 }, 8350 if(length(y) && any(nzchar(z <- y$CRAN))) { 8351 ul <- tolower(z) 8352 indp <- (grepl("^https?://cran.r-project.org/web/packages", 8353 ul) & 8354 !grepl("^https?://cran.r-project.org/web/packages/[.[:alnum:]_]+(html|pdf|rds)$", 8355 ul)) 8356 indv <- grepl("https?://cran.r-project.org/web/views/[[:alnum:]]+[.]html$", 8357 ul) 8358 paste(c(if(any(indp)) { 8359 c(" The canonical URL of the CRAN page for a package is ", 8360 " https://CRAN.R-project.org/package=pkgname") 8361 }, 8362 if(any(indv)) { 8363 c(" The canonical URL of the CRAN page for a task view is ", 8364 " https://CRAN.R-project.org/view=viewname") 8365 }, 8366 if(any(nzchar(z) & !indp & !indv)) { 8367 " Canonical CRAN.R-project.org URLs use https." 8368 }), 8369 collapse = "\n") 8370 }, 8371 if(length(y) && any(nzchar(y$Spaces))) { 8372 " Spaces in an http[s] URL should probably be replaced by %20" 8373 }, 8374 if(length(y) && any(ind <- nzchar(z <- y$R))) { 8375 ul <- tolower(z[ind]) 8376 elts <- unique(sub("^http://([^.]+)[.].*", "\\1", ul)) 8377 paste(sprintf(" Canonical %s.R-project.org URLs use https.", 8378 elts), 8379 collapse = "\n") 8380 }, 8381 if(length(y <- x$no_url_checks) && y) { 8382 "Checking URLs requires 'libcurl' support in the R build" 8383 })), 8384 if(length(y <- x$bad_file_URIs)) { 8385 paste(c(if(NROW(y) > 1L) 8386 "Found the following (possibly) invalid file URIs:" 8387 else 8388 "Found the following (possibly) invalid file URI:", 8389 sprintf(" URI: %s\n From: %s", y[, 1L], y[, 2L])), 8390 collapse = "\n") 8391 }, 8392 fmt(if(length(y <- x$bad_dois)) { 8393 if(inherits(y, "error")) 8394 paste(c("Checking DOIs failed with message:", 8395 conditionMessage(y)), 8396 collapse = "\n") 8397 else 8398 paste(c(if(length(y) > 1L) 8399 "Found the following (possibly) invalid DOIs:" 8400 else 8401 "Found the following (possibly) invalid DOI:", 8402 paste0(" ", gsub("\n", "\n ", format(y), 8403 fixed = TRUE))), 8404 collapse = "\n") 8405 }), 8406 fmt(if(length(y <- x$bad_arXiv_ids)) { 8407 paste(c(if(length(y) > 1L) 8408 "The Description field contains the following (possibly) invalid arXiv ids:" 8409 else 8410 "The Description field contains the following (possibly) invalid arXiv id:", 8411 paste0(" ", gsub("\n", "\n ", format(y), 8412 fixed = TRUE))), 8413 collapse = "\n") 8414 }), 8415 fmt(if(length(y <- x$bad_ORCID_iDs)) { 8416 paste(c(if(NROW(y) > 1L) 8417 "Found the following (possibly) invalid ORCID iDs:" 8418 else 8419 "Found the following (possibly) invalid ORCID iD:", 8420 sprintf(" iD: %s\t(from: %s)", 8421 unlist(y[, 1L]), 8422 vapply(y[, 2L], paste, "", 8423 collapse = ", "))), 8424 collapse = "\n") 8425 }), 8426 if(length(y <- x$R_files_non_ASCII)) { 8427 paste(c("No package encoding and non-ASCII characters in the following R files:", 8428 paste0(" ", names(y), "\n ", 8429 vapply(y, paste, "", collapse = "\n "), 8430 collapse = "\n")), 8431 collapse = "\n") 8432 }, 8433 if(length(y <- x$R_files_set_random_seed)) { 8434 paste(c(sprintf("File '%s' sets .Random.seed.", 8435 file.path("R", y)), 8436 "This is usually neither needed nor wanted."), 8437 collapse = "\n") 8438 }, 8439 fmt(c(if(length(x$title_is_name)) { 8440 "The Title field is just the package name: provide a real title." 8441 }, 8442 if(length(x$title_includes_name)) { 8443 "The Title field starts with the package name." 8444 }, 8445 if(length(y <- x$title_case)) { 8446 paste(c("The Title field should be in title case. Current version is:", 8447 sQuote(y[1L]), "In title case that is:", sQuote(y[2L])), 8448 collapse = "\n") 8449 })), 8450 fmt(c(if(length(x$descr_bad_initial)) { 8451 "The Description field should start with a capital letter." 8452 }, 8453 if(length(x$descr_bad_start)) { 8454 "The Description field should not start with the package name,\n 'This package' or similar." 8455 }, 8456 if(length(y <- x$descr_bad_URLs)) { 8457 paste(c("The Description field contains", 8458 paste0(" ", y), 8459 "Please enclose URLs in angle brackets (<...>)."), 8460 collapse = "\n") 8461 }, 8462 if(length(y <- x$descr_bad_DOIs)) { 8463 paste(c("The Description field contains", 8464 paste0(" ", y), 8465 "Please write DOIs as <doi:10.prefix/suffix>."), 8466 collapse = "\n") 8467 }, 8468 if(length(y <- x$descr_bad_arXiv_ids)) { 8469 paste(c("The Description field contains", 8470 paste0(" ", y), 8471 "Please write arXiv ids as <arXiv:YYMM.NNNNN>."), 8472 collapse = "\n") 8473 } 8474 )), 8475 fmt(c(if(length(x$GNUmake)) { 8476 "GNU make is a SystemRequirements." 8477 })), 8478 fmt(c(if(length(x$bad_date)) { 8479 "The Date field is not in ISO 8601 yyyy-mm-dd format." 8480 }, 8481 if(length(x$old_date)) { 8482 "The Date field is over a month old." 8483 })), 8484 if(length(y <- x$build_time_stamp_msg)) y, 8485 if(length(y <- x$placeholders)) { 8486 paste(c("DESCRIPTION fields with placeholder content:", 8487 paste0(" ", 8488 unlist(strsplit(formatDL(y, 8489 style = "list", 8490 indent = 2L), 8491 "\n", fixed = TRUE)))), 8492 collapse = "\n") 8493 }, 8494 if(length(y <- x$size_of_tarball)) 8495 paste("Size of tarball:", y, "bytes"), 8496 fmt(c(if(length(y <- x$Rd_keywords_or_concepts_with_Rd_markup)) 8497 paste(c("Found the following \\keyword or \\concept entries with Rd markup:", 8498 unlist(y)), 8499 collapse = "\n"), 8500 if(length(y <- x$Rd_keywords_or_concepts_more_than_one)) 8501 paste(c("Found the following \\keyword or \\concept entries", 8502 "which likely give several index terms:", 8503 unlist(y)), 8504 collapse = "\n"), 8505 if(length(y <- x$Rd_URLs_which_should_use_doi)) 8506 paste(c("Found the following URLs which should use \\doi (with the DOI name only):", 8507 unlist(y)), 8508 collapse = "\n"))) 8509 ) 8510} 8511 8512print.check_package_CRAN_incoming <- 8513function(x, ...) 8514{ 8515 if(length(y <- format(x, ...))) 8516 writeLines(paste(y, collapse = "\n\n")) 8517 invisible(x) 8518} 8519 8520### * .check_Rd_metadata 8521 8522.check_Rd_metadata <- 8523function(package, dir, lib.loc = NULL) 8524{ 8525 ## Perform package-level Rd metadata checks: 8526 ## names and aliases must be unique within a package. 8527 8528 ## Note that we cannot use Rd_aliases(), as this does 8529 ## if(length(aliases)) 8530 ## sort(unique(unlist(aliases, use.names = FALSE))) 8531 8532 out <- structure(list(), class = "check_Rd_metadata") 8533 8534 if(!missing(package)) { 8535 if(length(package) != 1L) 8536 stop("argument 'package' must be of length 1") 8537 dir <- find.package(package, lib.loc) 8538 rds <- file.path(dir, "Meta", "Rd.rds") 8539 if(file_test("-f", rds)) { 8540 meta <- readRDS(rds) 8541 files <- meta$File 8542 names <- meta$Name 8543 aliases <- meta$Aliases 8544 } else { 8545 return(out) 8546 } 8547 } else { 8548 if(dir.exists(file.path(dir, "man"))) { 8549 db <- Rd_db(dir = dir) 8550 files <- basename(names(db)) 8551 names <- sapply(db, .Rd_get_metadata, "name") 8552 aliases <- lapply(db, .Rd_get_metadata, "alias") 8553 } else { 8554 return(out) 8555 } 8556 } 8557 8558 ## <FIXME> 8559 ## Remove eventually, as .Rd_get_metadata() and hence Rd_info() now 8560 ## eliminate duplicated entries ... 8561 aliases <- lapply(aliases, unique) 8562 ## </FIXME> 8563 8564 files_grouped_by_names <- split(files, names) 8565 files_with_duplicated_names <- 8566 files_grouped_by_names[lengths(files_grouped_by_names) > 1L] 8567 if(length(files_with_duplicated_names)) 8568 out$files_with_duplicated_names <- 8569 files_with_duplicated_names 8570 8571 files_grouped_by_aliases <- 8572 split(rep.int(files, lengths(aliases)), 8573 unlist(aliases, use.names = FALSE)) 8574 files_with_duplicated_aliases <- 8575 files_grouped_by_aliases[lengths(files_grouped_by_aliases) > 1L] 8576 if(length(files_with_duplicated_aliases)) 8577 out$files_with_duplicated_aliases <- 8578 files_with_duplicated_aliases 8579 8580 out 8581} 8582 8583format.check_Rd_metadata <- 8584function(x, ...) 8585{ 8586 c(character(), 8587 if(length(bad <- x$files_with_duplicated_name)) { 8588 unlist(lapply(names(bad), 8589 function(nm) { 8590 c(gettextf("Rd files with duplicated name '%s':", 8591 nm), 8592 .pretty_format(bad[[nm]])) 8593 })) 8594 }, 8595 if(length(bad <- x$files_with_duplicated_aliases)) { 8596 unlist(lapply(names(bad), 8597 function(nm) { 8598 c(gettextf("Rd files with duplicated alias '%s':", 8599 nm), 8600 .pretty_format(bad[[nm]])) 8601 })) 8602 }) 8603} 8604 8605## * checkRdContents 8606 8607checkRdContents <- # was .check_Rd_contents <- 8608function(package, dir, lib.loc = NULL, chkInternal = FALSE) 8609{ 8610 out <- list() 8611 class(out) <- "checkRdContents" # was "check_Rd_contents" 8612 8613 ## Argument handling. 8614 if(!missing(package)) { 8615 if(length(package) != 1L) 8616 stop("argument 'package' must be of length 1") 8617 dir <- find.package(package, lib.loc) 8618 ## Using package installed in @code{dir} ... 8619 } 8620 else { 8621 if(missing(dir)) 8622 stop("you must specify 'package' or 'dir'") 8623 ## Using sources from directory @code{dir} ... 8624 if(!dir.exists(dir)) 8625 stop(gettextf("directory '%s' does not exist", dir), 8626 domain = NA) 8627 else 8628 dir <- file_path_as_absolute(dir) 8629 } 8630 8631 db <- if(!missing(package)) 8632 Rd_db(package, lib.loc = dirname(dir)) 8633 else 8634 Rd_db(dir = dir) 8635 8636 if(!chkInternal && ## Exclude internal objects from further computations. 8637 any(ind <- vapply(lapply(db, .Rd_get_metadata, "keyword"), 8638 function(x) "internal" %in% x, NA))) { 8639 db <- db[!ind] 8640 } 8641 8642 names(db) <- .Rd_get_names_from_Rd_db(db) 8643 for(nm in names(db)) { 8644 rd <- db[[nm]] 8645 8646 ## Arguments with no description. 8647 arg_table <- .Rd_get_argument_table(rd) 8648 arguments_with_no_description <- 8649 arg_table[grepl("^[[:blank:]]*$", arg_table[, 2L]), 8650 1L] 8651 8652 ## Autogenerated Rd content which needs editing. 8653 offending_autogenerated_content <- 8654 .Rd_get_offending_autogenerated_content(rd) 8655 8656 if(length(arguments_with_no_description) 8657 || length(offending_autogenerated_content)) { 8658 out[[nm]] <- 8659 list(arguments_with_no_description = 8660 arguments_with_no_description, 8661 offending_autogenerated_content = 8662 offending_autogenerated_content) 8663 } 8664 } 8665 8666 out 8667} 8668 8669format.checkRdContents <- 8670function(x, ...) 8671{ 8672 .fmt <- function(nm) { 8673 y <- x[[nm]] 8674 c(if(length(arguments_with_no_description <- 8675 y[["arguments_with_no_description"]])) { 8676 c(gettextf("Argument items with no description in Rd object '%s':", 8677 nm), 8678 .pretty_format(arguments_with_no_description)) 8679 }, 8680 if(length(offending_autogenerated_content <- 8681 y[["offending_autogenerated_content"]])) { 8682 c(gettextf("Auto-generated content requiring editing in Rd object '%s':", 8683 nm), 8684 sprintf(" %s", offending_autogenerated_content[, 1L])) 8685 }, 8686 "") 8687 } 8688 8689 as.character(unlist(lapply(names(x), .fmt))) 8690} 8691 8692### * .check_Rd_line_widths 8693 8694.check_Rd_line_widths <- 8695function(dir, limit = c(usage = 95, examples = 105), installed = FALSE) 8696{ 8697 db <- if(installed) 8698 Rd_db(basename(dir), lib.loc = dirname(dir)) 8699 else 8700 Rd_db(dir = dir) 8701 out <- find_wide_Rd_lines_in_Rd_db(db, limit, installed) 8702 class(out) <- "check_Rd_line_widths" 8703 attr(out, "limit") <- limit 8704 out 8705} 8706 8707format.check_Rd_line_widths <- 8708function(x, ...) 8709{ 8710 if(!length(x)) return(character()) 8711 8712 .truncate <- function(s) { 8713 ifelse(nchar(s) > 140L, 8714 paste(substr(s, 1, 140L), 8715 "... [TRUNCATED]"), 8716 s) 8717 } 8718 8719 limit <- attr(x, "limit") 8720 ## Rd2txt() by default adds a section indent of 5 also incorporated 8721 ## in the limits used for checking. But users actually look at the 8722 ## line widths in their source Rd file, so remove the indent when 8723 ## formatting for reporting check results. 8724 ## (This should reduce confusion as long as we only check the line 8725 ## widths in verbatim type sections.) 8726 limit <- limit - 5L 8727 8728 sections <- names(limit) 8729 8730 .fmt <- function(nm) { 8731 y <- x[[nm]] 8732 c(sprintf("Rd file '%s':", nm), 8733 unlist(lapply(sections, 8734 function(s) { 8735 lines <- y[[s]] 8736 if(!length(lines)) character() else { 8737 c(sprintf(" \\%s lines wider than %d characters:", 8738 s, limit[s]), 8739 .truncate(lines)) 8740 } 8741 }), 8742 use.names = FALSE), 8743 "") 8744 } 8745 8746 as.character(unlist(lapply(names(x), .fmt))) 8747} 8748 8749find_wide_Rd_lines_in_Rd_db <- 8750function(x, limit = NULL, installed = FALSE) 8751{ 8752 y <- lapply(x, find_wide_Rd_lines_in_Rd_object, limit, installed) 8753 Filter(length, y) 8754} 8755 8756find_wide_Rd_lines_in_Rd_object <- 8757function(x, limit = NULL, installed = FALSE) 8758{ 8759 if(is.null(limit)) 8760 limit <- list(usage = c(79, 95), examples = c(87, 105)) 8761 sections <- names(limit) 8762 if(is.null(sections)) 8763 stop("no Rd sections specified") 8764 if (installed) x <- prepare_Rd(x, stages = "render") 8765 y <- Map(function(s, l) { 8766 out <- NULL 8767 zz <- textConnection("out", "w", local = TRUE) 8768 on.exit(close(zz)) 8769 pos <- which(RdTags(x) == s) 8770 ## measure length in chars, not in bytes after substitutions 8771 Rd2txt(x[pos[1L]], out = zz, fragment = TRUE, outputEncoding = "UTF-8") 8772 nc <- nchar(sub("[ \t]+$", "", out)) 8773 if(length(l) > 1L) { 8774 ind_warn <- (nc > max(l)) 8775 ind_note <- (nc > min(l)) & !ind_warn 8776 Filter(length, 8777 list(warn = out[ind_warn], note = out[ind_note])) 8778 } else { 8779 out[nc > l] 8780 } 8781 }, 8782 paste0("\\", sections), 8783 limit) 8784 names(y) <- sections 8785 Filter(length, y) 8786} 8787 8788 8789### * .find_charset 8790 8791.find_charset <- 8792function() 8793{ 8794 l10n <- l10n_info() 8795 enc <- if(l10n[["UTF-8"]]) "UTF-8" else utils::localeToCharset() 8796 cat("charset: ", enc, "\n", sep = "") 8797 invisible() 8798} 8799 8800 8801### * Utilities 8802 8803### ** as.alist.call 8804 8805as.alist.call <- 8806function(x) 8807{ 8808 y <- as.list(x) 8809 ind <- if(is.null(names(y))) 8810 seq_along(y) 8811 else 8812 which(names(y) == "") 8813 if(length(ind)) { 8814 names(y)[ind] <- vapply(y[ind], paste, "", collapse = " ") 8815 y[ind] <- rep.int(list(alist(irrelevant = )[[1L]]), length(ind)) 8816 } 8817 y 8818} 8819 8820### ** as.alist.symbol 8821 8822as.alist.symbol <- 8823function(x) 8824{ 8825 as.alist.call(call(as.character(x))) 8826} 8827 8828### ** .arg_names_from_call 8829 8830.arg_names_from_call <- 8831function(x) 8832{ 8833 y <- as.character(x) 8834 if(!is.null(nx <- names(x))) { 8835 ind <- which(nzchar(nx)) 8836 y[ind] <- nx[ind] 8837 } 8838 y 8839} 8840 8841### ** .dquote_method_markup 8842 8843## See the notes below. 8844## An alternative and possibly more efficient implementation could be 8845## based using gregexpr(re, txt), massaging the matches and merging with 8846## the non-matched parts. 8847 8848.dquote_method_markup <- 8849function(txt, re) 8850{ 8851 out <- "" 8852 while((ipos <- regexpr(re, txt)) > -1L) { 8853 epos <- ipos + attr(ipos, "match.length") - 1L 8854 str <- substring(txt, ipos, epos) 8855 str <- sub("\"", "\\\"", str, fixed = TRUE) 8856 str <- sub("\\", "\\\\", str, fixed = TRUE) 8857 out <- sprintf("%s%s\"%s\"", out, 8858 substring(txt, 1L, ipos - 1L), str) 8859 txt <- substring(txt, epos + 1L) 8860 } 8861 paste0(out, txt) 8862} 8863 8864### ** .format_calls_in_file 8865 8866.format_calls_in_file <- 8867function(calls, f) 8868{ 8869 c(gettextf("File %s:", sQuote(f)), 8870 paste0(" ", 8871 unlist(lapply(calls, 8872 function(e) 8873 paste(deparse(e), collapse = "\n"))))) 8874} 8875 8876### ** .functions_to_be_ignored_from_usage 8877 8878.functions_to_be_ignored_from_usage <- 8879function(package_name) 8880{ 8881 c("<-", "=", 8882 if(package_name == "base") 8883 c("(", "{", "function", "if", "for", "while", "repeat", 8884 "Math", "Ops", "Summary", "Complex"), 8885 if(package_name == "utils") "?", 8886 if(package_name == "methods") "@") 8887} 8888 8889### ** get_S4_generics_with_methods 8890 8891## FIXME: make option of methods::getGenerics() 8892## JMC agreed & proposed argument 'excludeEmpty = FALSE' 8893get_S4_generics_with_methods <- 8894function(env, verbose = getOption("verbose")) 8895{ 8896 env <- as.environment(env) 8897 ## Filter(function(g) methods::isGeneric(g, where = env), 8898 ## methods::getGenerics(env)) 8899 r <- methods::getGenerics(env) 8900 if(length(r) && { 8901 hasM <- lapply(r, function(g) 8902 tryCatch(methods::hasMethods(g, where = env), 8903 error = identity)) 8904 if(any(hasErr <- vapply(hasM, inherits, NA, what = "error"))) { 8905 dq <- function(ch) paste0('"', ch ,'"') 8906 rErr <- r[hasErr] 8907 pkgs <- r@package[hasErr] 8908 ## FIXME: This warning should not happen here when called 8909 ## from R CMD check, but rather be part of a new "check" 8910 ## there ! 8911 warning(gettextf("Generics 'g' in 'env' %s where '%s' errors: %s\nMay need something like\n\n%s\nin NAMESPACE.", 8912 format(env), 8913 "hasMethods(g, env)", 8914 paste(sQuote(rErr), collapse = ", "), 8915 paste0(" importFrom(", 8916 paste(dq(pkgs), dq(rErr), sep =", "), 8917 ")\n") 8918 ), 8919 domain = NA) 8920 hasM <- hasM[!hasErr] 8921 } 8922 !all(ok <- unlist(hasM)) 8923 }) { 8924 if(verbose) 8925 message(sprintf(ngettext(sum(!ok), 8926 "Generic without any methods in %s: %s", 8927 "Generics without any methods in %s: %s"), 8928 format(env), 8929 paste(sQuote(r[!ok]), collapse = ", ")), 8930 domain = NA) 8931 r[ok] 8932 } 8933 else as.vector(r)# for back-compatibility and current ..../tests/reg-S4.R 8934} 8935 8936### ** .get_S4_generics 8937 8938## For several QC tasks, we need to compute on "all S4 methods in/from a 8939## package". These days, this can straightforwardly be accomplished by 8940## looking at all methods tables in the package environment or namespace. 8941## Somewhat historically, we organize our computations by first using 8942## using methods::getGenerics() to find all S4 generics the package has 8943## methods for, and then iterating over these. To make this work 8944## conveniently, we wrap around methods::getGenerics() to rewrite its 8945## "ObjectsWithPackage" result into a (currently unclassed) list of 8946## generic-name-with-package-name-attribute objects, and wrap around 8947## methods::findMethods() to perform lookup based on this information 8948## (rather than the genericFunction object itself), and also rewrite the 8949## MethodsList result into a simple list. 8950 8951.get_S4_generics <- 8952function(env) 8953{ 8954 env <- as.environment(env) 8955 g <- suppressMessages(methods::getGenerics(env)) 8956 Map(function(f, p) { 8957 attr(f, "package") <- p 8958 f 8959 }, 8960 g@.Data, 8961 g@package) 8962} 8963 8964### ** .get_S4_methods_list 8965 8966.get_S4_methods_list <- 8967function(f, env) 8968{ 8969 ## Get S4 methods in environment env for f a structure with the name 8970 ## of the S4 generic and its package in the corresponding attribute. 8971 8972 ## For the QC computations, we really only want the S4 methods 8973 ## defined in a package, so we try to exclude derived default 8974 ## methods as well as methods inherited from other environments. 8975 8976 env <- as.environment(env) 8977 8978 ## <FIXME> 8979 ## Use methods::findMethods() once this gets a package argument. 8980 ## This will return a listOfMethods object: turn this into a simple 8981 ## list of methods named by hash-collapsed signatures. 8982 tab <- get(methods:::.TableMetaName(f, attr(f, "package")), envir = env) 8983 mlist <- as.list(tab, all.names = TRUE, sorted = TRUE) 8984 ## </FIXME> 8985 8986 ## First, derived default methods (signature w/ "ANY"). 8987 if(any(ind <- vapply(mlist, methods::is, NA, "derivedDefaultMethod"))) 8988 mlist <- mlist[!ind] 8989 8990 if(length(mlist)) { 8991 ## Determining the methods defined in a package from the package 8992 ## env or the associated namespace seems rather tricky. What we 8993 ## seem to observe is the following. 8994 ## * If there is a namespace N, methods defined in the package 8995 ## have N as their environment, for both the package env and 8996 ## the associated namespace. 8997 ## * If there is no namespace, methods defined in the package 8998 ## have an environment E which is empty and has globalenv() as 8999 ## its parent. (If the package defines generics, these seem 9000 ## to have E as their parent env.) 9001 ## However, in the latter case, there seems no way to infer E 9002 ## from the package env. In the old days predating methods 9003 ## tables, we compared methods in the package env with those in 9004 ## its parent env, and excluded the ones already found there. 9005 ## This no longer works, so we exclude "at least" all methods 9006 ## with a namespace environment (as these cannot come from a 9007 ## package with no namespace). 9008 9009 namespace <- if(isNamespace(env)) env else .get_namespace_from_package_env(env) 9010 mlist <- if(!is.null(namespace)) 9011 Filter(function(m) identical(environment(m), namespace), mlist) 9012 else 9013 Filter(function(m) environmentName(environment(m)) == "", mlist) 9014 } 9015 9016 mlist 9017} 9018 9019.get_ref_classes <- 9020function(env) 9021{ 9022 env <- as.environment(env) 9023 cl <- methods::getClasses(env) 9024 cl <- cl[vapply(cl, 9025 function(Class) 9026 methods::is(methods::getClass(Class, where = env), 9027 "refClassRepresentation"), 9028 NA)] 9029 if(length(cl)) { 9030 res <- lapply(cl, function(Class) { 9031 def <- methods::getClass(Class, where = env) 9032 ff <- def@fieldPrototypes 9033 accs <- vapply(ff, 9034 function(what) 9035 methods::is(what, "activeBindingFunction") && 9036 !methods::is(what, "defaultBindingFunction"), 9037 NA) 9038 c(as.list(def@refMethods), as.list(ff)[accs]) 9039 }) 9040 names(res) <- cl 9041 res 9042 } else list() 9043} 9044 9045.get_namespace_from_package_env <- 9046function(env) 9047{ 9048 package <- 9049 sub(".*:([^_]*).*", "\\1", attr(env, "name", exact = TRUE)) 9050 if(length(package) && nzchar(package)) .getNamespace(as.name(package)) 9051} 9052 9053 9054### ** .is_call_from_replacement_function_usage 9055 9056.is_call_from_replacement_function_usage <- 9057function(x) 9058{ 9059 ((length(x) == 3L) 9060 && identical(x[[1L]], quote(`<-`)) 9061 && (length( x[[2L]]) > 1L) 9062 && is.symbol(x[[3L]])) 9063} 9064 9065### ** .make_siglist 9066 9067.make_siglist <- 9068function(x) 9069{ 9070 ## Argument 'x' should be a named list of methods as obtained by 9071 ## methods::findMethods() or .get_S4_methods_list(). 9072 gsub("#", ",", names(x), fixed = TRUE) 9073} 9074 9075### ** .make_signatures 9076 9077.make_signatures <- 9078function(cls) 9079{ 9080 ## Note that (thanks JMC), when comparing signatures, the signature 9081 ## has to be stripped of trailing "ANY" elements (which are always 9082 ## implicit) or padded to a fixed length. 9083 sub("(#ANY)*$", "", unlist(lapply(cls, paste, collapse = "#"))) 9084} 9085 9086### ** .massage_file_parse_error_message 9087 9088.massage_file_parse_error_message <- 9089function(x) 9090 sub("^[^:]+:[[:space:]]*", "", x) 9091 9092### ** .package_env 9093 9094.package_env <- 9095function(package_name) 9096{ 9097 as.environment(paste0("package:", package_name)) 9098} 9099 9100### ** .parse_text_as_much_as_possible 9101 9102.parse_text_as_much_as_possible <- 9103function(txt) 9104{ 9105 exprs <- tryCatch(str2expression(txt), error = identity) 9106 if(!inherits(exprs, "error")) return(exprs) 9107 exprs <- expression() 9108 lines <- unlist(strsplit(txt, "\n")) 9109 bad_lines <- character() 9110 while((n <- length(lines))) { 9111 i <- 1L; txt <- lines[1L] 9112 while(inherits(yy <- tryCatch(str2expression(txt), 9113 error = identity), 9114 "error") 9115 && (i < n)) { 9116 i <- i + 1L; txt <- paste(txt, lines[i], collapse = "\n") 9117 } 9118 if(inherits(yy, "error")) { 9119 bad_lines <- c(bad_lines, lines[1L]) 9120 lines <- lines[-1L] 9121 } 9122 else { 9123 exprs <- c(exprs, yy) 9124 lines <- lines[-seq_len(i)] 9125 } 9126 } 9127 attr(exprs, "bad_lines") <- bad_lines 9128 exprs 9129} 9130 9131### ** .parse_usage_as_much_as_possible 9132 9133.parse_usage_as_much_as_possible <- 9134function(x) 9135{ 9136 if(!length(x)) return(expression()) 9137 ## Drop specials and comments. 9138 ## <FIXME> 9139 ## Remove calling .Rd_drop_comments() eventually. 9140 x <- .Rd_drop_comments(x) 9141 ## </FIXME> 9142 txt <- .Rd_deparse(.Rd_drop_nodes_with_tags(x, "\\special"), 9143 tag = FALSE) 9144 txt <- gsub("\\\\l?dots", "...", txt) 9145 txt <- .dquote_method_markup(txt, .S3_method_markup_regexp) 9146 txt <- .dquote_method_markup(txt, .S4_method_markup_regexp) 9147 ## Transform <<see below>> style markup so that we can catch and 9148 ## throw it, rather than "basically ignore" it by putting it in the 9149 ## bad_lines attribute. 9150 txt <- gsub("(<<?see below>>?)", "`\\1`", txt) 9151 ## \usage is only 'verbatim-like' 9152 ## ## <FIXME> 9153 ## ## 'LanguageClasses.Rd' in package methods has '"\{"' in its usage. 9154 ## ## But why should it use the backslash escape? 9155 ## txt <- gsub("\\{", "{", txt, fixed = TRUE) 9156 ## txt <- gsub("\\}", "}", txt, fixed = TRUE) 9157 ## ## </FIXME> 9158 ## now any valid escape by \ is 9159 ## \a \b \f \n \r \t \u \U \v \x \' \" \\ or \octal 9160 txt <- gsub("(^|[^\\])\\\\($|[^abfnrtuUvx0-9'\"\\])", 9161 "\\1<unescaped bksl>\\2", txt) 9162 ## and since this may overlap, try again 9163 txt <- gsub("(^|[^\\])\\\\($|[^abfnrtuUvx0-9'\"\\])", 9164 "\\1<unescaped bksl>\\2", txt) 9165 .parse_text_as_much_as_possible(txt) 9166} 9167 9168### ** .pretty_format 9169 9170.strwrap22 <- function(x, collapse = " ") 9171 strwrap(paste(x, collapse=collapse), indent = 2L, exdent = 2L) 9172 9173.pretty_format <- 9174function(x, collapse = " ", q = getOption("useFancyQuotes")) 9175 .strwrap22(sQuote(x, q=q), collapse=collapse) 9176 9177.pretty_format2 <- 9178function(msg, x, collapse = ", ", useFancyQuotes = FALSE) 9179{ 9180 xx <- strwrap(paste(sQuote(x, q=q), collapse=collapse), exdent = 2L) 9181 if (length(xx) > 1L || nchar(msg) + nchar(xx) + 1L > 75L) 9182 ## trash 'xx', instead wrap w/ 'indent' : 9183 c(msg, .pretty_format(x, collapse=collapse, q=q)) 9184 else paste(msg, xx) 9185} 9186 9187### ** .pretty_print 9188 9189.pretty_print <- 9190function(x, collapse = " ") 9191 writeLines(.strwrap22(x, collapse=collapse)) 9192 9193 9194### ** .strip_backticks 9195 9196.strip_backticks <- 9197function(x) 9198 gsub("`", "", x, fixed=TRUE) 9199 9200### ** .transform_S3_method_markup 9201 9202.transform_S3_method_markup <- 9203function(x) 9204{ 9205 ## Note how we deal with S3 replacement methods found. 9206 ## These come out named "\method{GENERIC}{CLASS}<-" which we 9207 ## need to turn into 'GENERIC<-.CLASS'. 9208 re <- sprintf("%s(<-)?", .S3_method_markup_regexp) 9209 ## Note that this is really only called on "function" names obtained 9210 ## by parsing the \usage texts, so that the method regexps possibly 9211 ## augmented by '<-' fully match if they match. 9212 ## We should be able to safely strip all backticks; alternatively, 9213 ## we could do something like 9214 ## cl <- .strip_backticks(sub(re, "\\4", x)) 9215 ## sub(re, sprintf("\\3\\5.%s", cl), x) 9216 .strip_backticks(sub(re, "\\3\\5.\\4", x)) 9217} 9218 9219### ** .transform_S4_method_markup 9220 9221.transform_S4_method_markup <- 9222function(x) 9223{ 9224 re <- sprintf("%s(<-)?", .S4_method_markup_regexp) 9225 ## We should be able to safely strip all backticks; alternatively, 9226 ## we could do something like 9227 ## sl <- .strip_backticks(sub(re, "\\3", x)) 9228 ## sub(re, sprintf("\\\\S4method{\\2\\7}{%s}", sl), x) 9229 .strip_backticks(sub(re, "\\\\S4method{\\2\\7}{\\3}", x)) 9230} 9231 9232### ** .S3_method_markup_regexp 9233 9234## For matching \(S3)?method{GENERIC}{CLASS}. 9235## GENERIC can be 9236## * a syntactically valid name 9237## * one of $ [ [[ 9238## * one of the binary operators 9239## + - * / ^ < <= > >= != == | & %something% 9240## * unary ! 9241## (as supported by Rdconv). 9242## CLASS can be a syntactic name (we could be more precise about the 9243## fact that these must start with a letter or '.'), or anything quoted 9244## by backticks (not containing backticks itself for now). Arguably, 9245## non-syntactic class names should best be avoided, but R has always 9246## had them at least for 9247## R> class(bquote({.})) 9248## [1] "{" 9249## R> class(bquote((.))) 9250## [1] "(" 9251 9252## <NOTE> 9253## Handling S3/S4 method markup is somewhat tricky. 9254## When using R to parse the usage entries, we turn the 9255## \METHOD{GENERIC}{CLASS_OR_SIGLIST}(args) 9256## markup into (something which parses to) a function call by suitably 9257## quoting the \METHOD{GENERIC}{CLASS_OR_SIGLIST} part. In case of a 9258## replacement method 9259## \METHOD{GENERIC}{CLASS_OR_SIGLIST}(args) <- value 9260## parsing results in a 9261## \METHOD{GENERIC}{CLASS_OR_SIGLIST}<- 9262## pseudo name, which need to be transformed to 9263## \METHOD{GENERIC<-}{CLASS_OR_SIGLIST} 9264## We currently use double quoting for the parse step. As we also allow 9265## for non-syntactic class names quoted by backticks, this means that 9266## double quotes and backslashes need to be escaped. Alternatively, we 9267## could strip backticks right away and quote by backticks, but then the 9268## replacement method transformation would need different regexps. 9269## </NOTE> 9270 9271.S3_method_markup_regexp <- 9272 sprintf("(\\\\(S3)?method\\{(%s)\\}\\{(%s)\\})", 9273 paste(c("[._[:alnum:]]*", 9274 ## Subscripting 9275 "\\$", "\\[\\[?", 9276 ## Binary operators and unary '!'. 9277 "\\+", "\\-", "\\*", "\\/", "\\^", 9278 "<=?", ">=?", "!=?", "==", "\\&", "\\|", 9279 "\\%[[:alnum:][:punct:]]*\\%"), 9280 collapse = "|"), 9281 "[._[:alnum:]]+|`[^`]+`") 9282 9283### ** .S4_method_markup_regexp 9284 9285## For matching \S4method{GENERIC}{SIGLIST}. 9286## SIGLIST can be a comma separated list of CLASS specs as above. 9287 9288.S4_method_markup_regexp <- 9289 sprintf("(\\\\S4method\\{(%s)\\}\\{(%s)\\})", 9290 paste(c("[._[:alnum:]]*", 9291 ## Subscripting 9292 "\\$", "\\[\\[?", 9293 ## Binary operators and unary '!'. 9294 "\\+", "\\-", "\\*", "\\/", "\\^", 9295 "<=?", ">=?", "!=?", "==", "\\&", "\\|", 9296 "\\%[[:alnum:][:punct:]]*\\%"), 9297 collapse = "|"), 9298 "(([._[:alnum:]]+|`[^`]+`),)*([._[:alnum:]]+|`[^`]+`)") 9299 9300### ** .valid_maintainer_field_regexp 9301 9302.make_RFC_2822_email_address_regexp <- 9303function() 9304{ 9305 ## Local part consists of ASCII letters and digits, the characters 9306 ## ! # $ % * / ? | ^ { } ` ~ & ' + = _ - 9307 ## and . provided it is not leading or trailing or repeated, or must 9308 ## be a quoted string. 9309 ## Domain part consists of dot-separated elements consisting of 9310 ## ASCII letters, digits and hyphen. 9311 ## We could also check that the local and domain parts are no longer 9312 ## than 64 and 255 characters, respectively. 9313 ## See https://en.wikipedia.org/wiki/Email_address. 9314 ASCII_letters_and_digits <- 9315 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" 9316 l <- sprintf("[%s%s]", ASCII_letters_and_digits, "!#$%*/?|^{}`~&'+=_-") 9317 d <- sprintf("[%s%s]", ASCII_letters_and_digits, "-") 9318 ## Be careful to arrange the hyphens to come last in the range spec. 9319 sprintf("(\\\".+\\\"|(%s+\\.)*%s+)@(%s+\\.)*%s+", l, l, d, d) 9320} 9321 9322.valid_maintainer_field_regexp <- 9323 sprintf("^[[:space:]]*(.*<%s>|ORPHANED)[[:space:]]*$", 9324 .make_RFC_2822_email_address_regexp()) 9325 9326### ** .Rd_get_offending_autogenerated_content 9327 9328.Rd_get_offending_autogenerated_content <- 9329function(x) 9330{ 9331 out <- NULL 9332 9333 ## /data/rsync/PKGS/geoR/man/globalvar.Rd 9334 s <- .Rd_get_section(x, "title") 9335 if(length(s)) { 9336 s <- .Rd_deparse(s, tag = FALSE) 9337 if(trimws(s) == "~~function to do ... ~~") 9338 out <- rbind(out, c("\\title", s)) 9339 } 9340 s <- .Rd_get_section(x, "description") 9341 if(length(s)) { 9342 s <- .Rd_deparse(s, tag = FALSE) 9343 if(trimws(s) == 9344 "~~ A concise (1-5 lines) description of what the function does. ~~") 9345 out <- rbind(out, c("\\description", s)) 9346 } 9347 s <- .Rd_get_section(x, "details") 9348 if(length(s)) { 9349 s <- .Rd_deparse(s, tag = FALSE) 9350 if(trimws(s) == 9351 "~~ If necessary, more details than the description above ~~") 9352 out <- rbind(out, c("\\details", s)) 9353 } 9354 9355 ## /data/rsync/PKGS/mimR/man/plot.Rd:\author{ ~~who you are~~ } 9356 s <- .Rd_get_section(x, "author") 9357 if(length(s)) { 9358 s <- .Rd_deparse(s, tag = FALSE) 9359 if(trimws(s) == "~~who you are~~") 9360 out <- rbind(out, c("\\author", s)) 9361 } 9362 ## /data/rsync/PKGS/mimR/man/mim-class.Rd:\note{ ~~further notes~~ } 9363 s <- .Rd_get_section(x, "note") 9364 if(length(s)) { 9365 s <- .Rd_deparse(s, tag = FALSE) 9366 if(trimws(s) == "~~further notes~~") 9367 out <- rbind(out, c("\\note", s)) 9368 } 9369 9370 tab <- .Rd_get_argument_table(x) 9371 if(length(tab)) { 9372 ## /data/rsync/PKGS/Rmpfr/man/mpfrArray.Rd: 9373 ## \item{precBits}{ ~~Describe \code{precBits} here~~ } 9374 descriptions <- trimws(tab[, 2L]) 9375 ind <- (descriptions == 9376 sprintf("~~Describe \\code{%s} here~~", tab[, 1L])) 9377 if(any(ind)) 9378 out <- rbind(out, 9379 cbind(sprintf("\\arguments, description of item '%s'", 9380 tab[ind, 1L]), 9381 tab[ind, 2L])) 9382 } 9383 9384 ## <NOTE> 9385 ## Obviously, auto-generation does too much here, so maybe do not 9386 ## include these in production check code ... 9387 tab <- .Rd_get_methods_description_table(x) 9388 if(length(tab)) { 9389 descriptions <- trimws(tab[, 2L]) 9390 ## /data/rsync/PKGS/coin/man/initialize-methods.Rd 9391 ind <- descriptions == "~~describe this method here" 9392 if(any(ind)) 9393 out <- rbind(out, 9394 cbind(sprintf("section 'Methods', description of item '%s'", 9395 tab[ind, 1L]), 9396 tab[ind, 2L])) 9397 } 9398 ## </NOTE> 9399 9400 if(config_val_to_logical(Sys.getenv("_R_CHECK_RD_CONTENTS_KEYWORDS_", 9401 "FALSE"))) { 9402 k <- .Rd_get_metadata(x, "keyword") 9403 k <- k[k %in% .Rd_keywords_auto] 9404 if(length(k)) { 9405 ## Not quite perfect as .Rd_get_metadata() already calls 9406 ## trimws() ... 9407 out <- rbind(out, 9408 cbind(sprintf("\\keyword{%s}", k), k)) 9409 } 9410 } 9411 9412 out 9413} 9414 9415 9416### ** .check_pragmas 9417 9418.check_pragmas <- 9419function(dir) 9420{ 9421 ## Check a source package for disallowed pragmas in src and inst/include 9422 ## Try (not very hard) to avoid ones which are commented out (RcppParallel) 9423 ## One could argue for recording all uses of #pragma ... diagnostic 9424 ## There are also 9425 ## #pragma warning (disable:4996) 9426 ## #pragma warning(push, 0) 9427 ## which seem intended for MSVC++ and hence not relevant here. 9428 found <- warn <- port <- character() 9429 od <- setwd(dir); on.exit(setwd(od)) 9430 ff <- dir(c('src', 'inst/include'), 9431 pattern = "[.](c|cc|cpp|h|hh|hpp)$", 9432 full.names = TRUE, recursive = TRUE) 9433 pat <- "^\\s*#pragma (GCC|clang) diagnostic ignored" 9434 ## -Wmissing-field-initializers looks important but is not part of -Wall 9435 pat2 <- "^\\s*#pragma (GCC|clang) diagnostic ignored[^-]*[-]W(uninitialized|float-equal|array-bound|format)" 9436 ## gcc8 -W warnings not accepted by clang 7 9437 ## found by listing with gcc -Q --help=warning and testing with clang. 9438 nonport <- 9439 c("abi-tag", "aggressive-loop-optimizations", "aliasing", 9440 "align-commons", "aligned-new", "alloc-size-larger-than", 9441 "alloc-zero", "alloca", "alloca-larger-than", "ampersand", 9442 "argument-mismatch", "array-temporaries", 9443 "assign-intercept", "attribute-alias", "bool-compare", 9444 "bool-operation", "builtin-declaration-mismatch", 9445 "c-binding-type", "c90-c99-compat", "c99-c11-compat", 9446 "cast-function-type", "catch-value", 9447 "character-truncation", "chkp", "class-memaccess", 9448 "clobbered", "compare-reals", "conditionally-supported", 9449 "conversion-extra", "coverage-mismatch", "designated-init", 9450 "discarded-array-qualifiers", "discarded-qualifiers", 9451 "do-subscript", "duplicated-branches", "duplicated-cond", 9452 "format-contains-nul", "format-overflow", 9453 "format-signedness", "format-truncation", "frame-address", 9454 "frame-larger-than", "free-nonheap-object", 9455 "function-elimination", "hsa", "if-not-aligned", 9456 "implicit-interface", "implicit-procedure", 9457 "inherited-variadic-ctor", "int-in-bool-context", 9458 "integer-division", "intrinsic-shadow", "intrinsics-std", 9459 "invalid-memory-model", "jump-misses-init", "larger-than", 9460 "line-truncation", "literal-suffix", "logical-op", 9461 "lto-type-mismatch", "maybe-uninitialized", 9462 "memset-elt-size", "misleading-indentation", 9463 "missing-attributes", "missing-parameter-type", 9464 "multiple-inheritance", "multistatement-macros", 9465 "namespaces", "noexcept", "non-template-friend", 9466 "nonnull-compare", "normalized", "old-style-declaration", 9467 "openmp-simd", "override-init", 9468 "override-init-side-effects", "packed-bitfield-compat", 9469 "packed-not-aligned", "placement-new", "pmf-conversions", 9470 "pointer-compare", "property-assign-default", "psabi", 9471 "real-q-constant", "realloc-lhs", "realloc-lhs-all", 9472 "restrict", "return-local-addr", "scalar-storage-order", 9473 "shadow-compatible-local", "shadow-local", 9474 "sized-deallocation", "sizeof-pointer-div", "stack-usage", 9475 "strict-null-sentinel", "stringop-overflow", 9476 "stringop-truncation", "subobject-linkage", 9477 "suggest-attribute", "suggest-final-methods", 9478 "suggest-final-types", "suggest-override", "surprising", 9479 "switch-unreachable", "sync-nand", "tabs", 9480 "target-lifetime", "templates", "terminate", "traditional", 9481 "traditional-conversion", "trampolines", 9482 "undefined-do-loop", "underflow", 9483 "unsafe-loop-optimizations", "unsuffixed-float-constants", 9484 "unused-but-set-parameter", "unused-but-set-variable", 9485 "unused-dummy-argument", "use-without-only", 9486 "useless-cast", "vector-operation-performance", 9487 "virtual-inheritance", "virtual-move-assign", 9488 "vla-larger-than", "zerotrip") 9489 pat3 <- paste0("^\\s*#pragma (GCC|clang) diagnostic[^-]*[-]W(", 9490 paste(nonport, collapse="|"), ")") 9491 for(f in ff) { 9492 if(any(grepl(pat, readLines(f, warn = FALSE), 9493 perl = TRUE, useBytes = TRUE))) 9494 found <- c(found, f) 9495 else next 9496 if(any(grepl(pat2, readLines(f, warn = FALSE), 9497 perl = TRUE, useBytes = TRUE))) 9498 warn <- c(warn, f) 9499 if(any(grepl(pat3, readLines(f, warn = FALSE), 9500 perl = TRUE, useBytes = TRUE))) 9501 port <- c(port, f) 9502 } 9503 structure(found, class = "check_pragmas", warn = warn, port = port) 9504} 9505 9506print.check_pragmas <- 9507function(x, ...) 9508{ 9509 if(length(x)) { 9510 if(length(x) == 1L) 9511 writeLines("File which contain pragma(s) suppressing diagnostics:") 9512 else 9513 writeLines("Files which contain pragma(s) suppressing diagnostics:") 9514 .pretty_print(x) 9515 } 9516 x 9517} 9518 9519### ** .check_S3_methods_needing_delayed_registration 9520 9521.check_S3_methods_needing_delayed_registration <- 9522function(package, lib.loc = NULL) 9523{ 9524 mat <- matrix(character(), 0L, 3L, 9525 dimnames = list(NULL, 9526 c("Package", "Generic", "Method"))) 9527 out <- list(mat = mat, bad = character()) 9528 class(out) <- "check_S3_methods_needing_delayed_registration" 9529 9530 if(length(package) != 1L) 9531 stop("argument 'package' must be of length 1") 9532 9533 if(package == "base") return() 9534 9535 dir <- find.package(package, lib.loc) 9536 if(!dir.exists(file.path(dir, "R"))) return() 9537 9538 db <- .read_description(file.path(dir, "DESCRIPTION")) 9539 suggests <- unname(.get_requires_from_package_db(db, "Suggests")) 9540 if(!length(suggests)) return() 9541 9542 reg <- parseNamespaceFile(package, dirname(dir))$S3methods 9543 reg <- reg[!is.na(reg[, 4L]), , drop = FALSE] 9544 if(length(reg)) 9545 out$reg <- cbind(Package = reg[, 4L], 9546 Generic = reg[, 1L], 9547 Class = reg[, 2L], 9548 Method = reg[, 3L]) 9549 9550 .load_package_quietly(package, dirname(dir)) 9551 ok <- vapply(suggests, requireNamespace, quietly = TRUE, 9552 FUN.VALUE = NA) 9553 out$bad <- suggests[!ok] 9554 9555 suggests <- suggests[ok] 9556 generics <- lapply(suggests, .get_S3_generics_in_ns_exports) 9557 9558 packages <- rep.int(suggests, lengths(generics)) 9559 generics <- unlist(generics, use.names = FALSE) 9560 9561 code_env <- .package_env(package) 9562 objects_in_code <- sort(names(code_env)) 9563 functions_in_code <- 9564 Filter(function(f) is.function(code_env[[f]]), 9565 objects_in_code) 9566 9567 ## Look only at the *additional* generics in suggests. 9568 ind <- (generics %notin% 9569 c(Filter(function(f) .is_S3_generic(f, code_env), 9570 functions_in_code), 9571 .get_S3_generics_as_seen_from_package(dir, TRUE, TRUE), 9572 .get_S3_group_generics(), 9573 .get_S3_primitive_generics())) 9574 if(!all(ind)) { 9575 generics <- generics[ind] 9576 packages <- packages[ind] 9577 } 9578 9579 methods_stop_list <- nonS3methods(basename(dir)) 9580 methods <- lapply(generics, 9581 function(g) { 9582 i <- startsWith(functions_in_code, 9583 paste0(g, ".")) 9584 setdiff(functions_in_code[i], 9585 methods_stop_list) 9586 }) 9587 len <- lengths(methods) 9588 ind <- (len > 0L) 9589 9590 if(!any(ind)) return(out) 9591 9592 len <- len[ind] 9593 out$mat <- 9594 cbind(Package = rep.int(packages[ind], len), 9595 Generic = rep.int(generics[ind], len), 9596 Method = unlist(methods[ind], use.names = FALSE)) 9597 out 9598} 9599 9600format.check_S3_methods_needing_delayed_registration <- 9601function(x, ...) 9602{ 9603 c(character(), 9604 if(length(bad <- x$bad)) { 9605 c("Suggested packages not available for checking:", 9606 strwrap(paste(bad, collapse = " "), indent = 2L)) 9607 }, 9608 if(length(mat <- x$mat)) { 9609 c("Apparent S3 methods needing delayed registration:", 9610 sprintf(" %s %s %s", 9611 format(c("Package", mat[, 1L])), 9612 format(c("Generic", mat[, 2L])), 9613 format(c("Method", mat[, 3L]))) 9614 ) 9615 }, 9616 if(length(reg <- x$reg)) { 9617 c("S3 methods using delayed registration:", 9618 sprintf(" %s %s %s %s", 9619 format(c("Package", reg[, 1L])), 9620 format(c("Generic", reg[, 2L])), 9621 format(c("Class", reg[, 3L])), 9622 format(c("Method", reg[, 4L]))) 9623 ) 9624 }) 9625} 9626 9627.get_S3_generics_in_ns_exports <- 9628function(ns) 9629{ 9630 env <- asNamespace(ns) 9631 nms <- sort(intersect(names(env), getNamespaceExports(env))) 9632 .get_S3_generics_in_env(env, nms) 9633} 9634 9635### ** .check_package_datalist 9636 9637.check_package_datalist <- 9638function(package, lib.loc = NULL) 9639{ 9640 out <- list() 9641 ans1 <- list_data_in_pkg(package, lib.loc) 9642 ans2 <- list_data_in_pkg(package, lib.loc, use_datalist = FALSE) 9643 ## Canonicalize. 9644 ans1 <- lapply(ans1, sort) 9645 ans1 <- ans1[order(names(ans1))] 9646 ans2 <- lapply(ans2, sort) 9647 ans2 <- ans2[order(names(ans2))] 9648 if(!identical(ans1, ans2)) { 9649 nx1 <- names(ans1) 9650 nx2 <- names(ans2) 9651 ex1 <- unlist(ans1) 9652 ex2 <- unlist(ans2) 9653 out <- Filter(length, 9654 list(n12 = setdiff(nx1, nx2), 9655 n21 = setdiff(nx2, nx1), 9656 e12 = setdiff(ex1, ex2), 9657 e21 = setdiff(ex2, ex1))) 9658 } 9659 class(out) <- "check_package_datalist" 9660 out 9661} 9662 9663format.check_package_datalist <- 9664function(x, ...) 9665{ 9666 fmt <- function(s) .strwrap22(s, " ") 9667 c(character(), 9668 if(length(y <- x$n12)) 9669 c("Data files in 'datalist' not in 'data' directory:", 9670 fmt(y)), 9671 if(length(y <- x$n21)) 9672 c("Data files in 'data' directory not in 'datalist':", 9673 fmt(y)), 9674 if(length(y <- x$e12)) 9675 c("Data objects in 'datalist' not in 'data' directory:", 9676 fmt(y)), 9677 if(length(y <- x$e21)) 9678 c("Data objects in 'data' directory not in 'datalist':", 9679 fmt(y))) 9680} 9681 9682### Local variables: *** 9683### mode: outline-minor *** 9684### outline-regexp: "### [*]+" *** 9685### End: *** 9686