The R Project SVN
R
(root)/branches/R-bool/src/library/utils/R/help.search.R – Rev 87966
Rev 87255 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
# File src/library/utils/R/help.search.R# Part of the R package, https://www.R-project.org## Copyright (C) 1995-2024 The R Core Team## This program is free software; you can redistribute it and/or modify# it under the terms of the GNU General Public License as published by# the Free Software Foundation; either version 2 of the License, or# (at your option) any later version.## This program is distributed in the hope that it will be useful,# but WITHOUT ANY WARRANTY; without even the implied warranty of# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the# GNU General Public License for more details.## A copy of the GNU General Public License is available at# https://www.R-project.org/Licenses/.hsearch_db <-local({hdb <- NULLfunction(new) {if(!missing(new))hdb <<- newelsehdb}})merge_vignette_index <-function(hDB, path, pkg){## Vignettes in the hsearch index started in R 2.14.0## Most packages don't have them, so the following should not be## too inefficientif(file.exists(v_file <- file.path(path, "Meta", "vignette.rds"))&& !is.null(vDB <- readRDS(v_file))&& nrow(vDB)) {## Make it look like an hDB base matrix and append itbase <- matrix("", nrow = nrow(vDB), ncol = 8L)colnames(base) <- colnames(hDB[[1L]])base[, "Package"] <- pkgbase[, "LibPath"] <- pathid <- as.character(1:nrow(vDB) + NROW(hDB[[1L]]))base[, "ID"] <- idbase[, "Name"] <- tools::file_path_sans_ext(basename(vDB$PDF))## As spotted by Henrik Bengtsson <henrik.bengtsson@gmail.com>,## using tools::file_path_sans_ext(basename(vDB$File) does not## work as intended, as non-Sweave vignettes could have nested## extensions (e.g., 'foo.tex.rsp' or 'foo.pdf.asis').## The docs say that the 'name' is the "base of the vignette## filename", which can be interpreted as above for the case of## nested extensions (and in fact, tools:::httpd() does so).base[, "Topic"] <- base[, "Name"]base[, "Title"] <- vDB$Titlebase[, "Type"] <- "vignette"hDB[[1L]] <- rbind(hDB[[1L]], base)aliases <- matrix("", nrow = nrow(vDB), ncol = 3L)colnames(aliases) <- colnames(hDB[[2L]])aliases[, "Alias"] <- base[, "Name"]aliases[, "ID"] <- idaliases[, "Package"] <- pkghDB[[2L]] <- rbind(hDB[[2L]], aliases)nkeywords <- sum(lengths(vDB$Keywords))if (nkeywords) {keywords <- matrix("", nrow = nkeywords, ncol = 3L)colnames(keywords) <- colnames(hDB[[4L]])keywords[,"Concept"] <- unlist(vDB$Keywords)keywords[,"ID"] <- unlist(lapply(1:nrow(vDB),function(i) rep.int(id[i], length(vDB$Keywords[[i]]))))keywords[,"Package"] <- pkghDB[[4L]] <- rbind(hDB[[4L]], keywords)}}hDB}merge_demo_index <-function(hDB, path, pkg){## Demos in the hsearch index started in R 2.14.0if(file.exists(d_file <- file.path(path, "Meta", "demo.rds"))&& !is.null(dDB <- readRDS(d_file))&& nrow(dDB)) {## Make it look like an hDB base matrix and append itbase <- matrix("", nrow = nrow(dDB), ncol = 8L)colnames(base) <- colnames(hDB[[1]])base[, "Package"] <- pkgbase[, "LibPath"] <- pathid <- as.character(1:nrow(dDB) + NROW(hDB[[1L]]))base[, "ID"] <- idbase[, "Name"] <- dDB[, 1L]base[, "Topic"] <- base[, "Name"]base[, "Title"] <- dDB[, 2L]base[, "Type"] <- "demo"hDB[[1L]] <- rbind(hDB[[1L]], base)aliases <- matrix("", nrow = nrow(dDB), ncol = 3L)colnames(aliases) <- colnames(hDB[[2L]])aliases[, "Alias"] <- base[, "Name"]aliases[, "ID"] <- idaliases[, "Package"] <- pkghDB[[2L]] <- rbind(hDB[[2L]], aliases)}hDB}hsearch_db_fields <-c("alias", "concept", "keyword", "name", "title")hsearch_db_types <-c("help", "vignette", "demo")## FIXME: use UTF-8, either always or optionally## (Needs UTF-8-savvy & fast agrep, and PCRE regexps.)help.search <-function(pattern, fields = c("alias", "concept", "title"),apropos, keyword, whatis, ignore.case = TRUE,package = NULL, lib.loc = NULL,help.db = getOption("help.db"),verbose = getOption("verbose"),rebuild = FALSE, agrep = NULL, use_UTF8 = FALSE,types = getOption("help.search.types")){### Argument handling..wrong_arg <- function(arg)gettextf("'%s' must be a character string", arg)if(is.logical(verbose)) verbose <- 2 * as.integer(verbose)fuzzy <- agrepif(!missing(pattern)) {if(!is.character(pattern) || (length(pattern) > 1L))stop(.wrong_arg("pattern"), domain = NA)i <- pmatch(fields, hsearch_db_fields)if(anyNA(i))stop("incorrect field specification")elsefields <- hsearch_db_fields[i]} else if(!missing(apropos)) {if(!is.character(apropos) || (length(apropos) > 1L))stop(.wrong_arg("apropos"), domain = NA)else {pattern <- aproposfields <- c("alias", "title")}} else if(!missing(keyword)) {if(!is.character(keyword) || (length(keyword) > 1L))stop(.wrong_arg("keyword"), domain = NA)else {pattern <- keywordfields <- "keyword"if(is.null(fuzzy)) fuzzy <- FALSE}} else if(!missing(whatis)) {if(!is.character(whatis) || (length(whatis) > 1))stop(.wrong_arg("whatis"), domain = NA)else {pattern <- whatisfields <- "alias"}} else {stop("do not know what to search")}if(!missing(help.db))warning("argument 'help.db' is deprecated")## This duplicates expansion in hsearch_db(), but there is no simple## way to avoid this.i <- pmatch(types, hsearch_db_types)if (anyNA(i))stop("incorrect type specification")elsetypes <- hsearch_db_types[i]### Set up the hsearch db.db <- hsearch_db(package, lib.loc, types, verbose, rebuild,use_UTF8)## Argument lib.loc was expanded when building the hsearch db, so## get from there.lib.loc <- attr(db, "LibPaths")## Subset to the requested help types if necessary.if(!identical(sort(types), sort(attr(db, "Types")))) {db$Base <- db$Base[!is.na(match(db$Base$Type, types)), ]db[-1L] <-lapply(db[-1L],function(e) {e[!is.na(match(e$ID, db$Base$ID)), ]})}if(!is.null(package)) {## Argument 'package' was given. Need to check that all given## packages exist in the db, and only search the given ones.pos_in_hsearch_db <-match(package, unique(db$Base[, "Package"]), nomatch = 0L)## This should not happen for R >= 2.4.0if(any(pos_in_hsearch_db) == 0L)stop(gettextf("no information in the database for package %s: need 'rebuild = TRUE'?",sQuote(package[pos_in_hsearch_db == 0][1L])),domain = NA)db[] <-lapply(db,function(e) {e[!is.na(match(e$Package, package)), ]})}### Matching.if(verbose >= 2L) {message("Database of ",NROW(db$Base), " help objects (",NROW(db$Aliases), " aliases, ",NROW(db$Concepts), " concepts, ",NROW(db$Keywords), " keywords)",domain = NA)flush.console()}## <FIXME>## No need continuing if there are no objects in the data base.## But shouldn't we return something of class "hsearch"?if(!length(db$Base)) return(invisible())## </FIXME>## If agrep is NULL (default), we want to use fuzzy matching iff## 'pattern' contains no characters special to regular expressions.## We use the following crude approximation: if pattern contains## only alphanumeric characters or whitespace or a '-', it is taken## 'as is', and fuzzy matching is used unless turned off explicitly,## or pattern has very few (currently, less than 5) characters.if(is.null(fuzzy) || is.na(fuzzy))fuzzy <-(grepl("^([[:alnum:]]|[[:space:]]|-)+$", pattern)&& (nchar(pattern, type="c") > 4L))if(is.logical(fuzzy)) {if(fuzzy)max.distance <- 0.1}else if(is.numeric(fuzzy) || is.list(fuzzy)) {max.distance <- fuzzyfuzzy <- TRUE}elsestop("incorrect 'agrep' specification")dbBase <- db$Basesearch_fun <- if(fuzzy) {function(x) {agrep(pattern, x, ignore.case = ignore.case,max.distance = max.distance)}} else {function(x) {grep(pattern, x, ignore.case = ignore.case,perl = use_UTF8)}}search_db_results <- function(p, f, e)list2DF(list(Position = p, Field = f, Entry = e))search_db_field <- function(field) {switch(field,alias = {aliases <- db$Aliases$Aliasmatched <- search_fun(aliases)search_db_results(match(db$Aliases$ID[matched],dbBase$ID),rep.int(field, length(matched)),aliases[matched])},concept = {concepts <- db$Concepts$Conceptmatched <- search_fun(concepts)search_db_results(match(db$Concepts$ID[matched],dbBase$ID),rep.int(field, length(matched)),concepts[matched])},keyword = {keywords <- db$Keywords$Keywordmatched <- search_fun(keywords)search_db_results(match(db$Keywords$ID[matched],dbBase$ID),rep.int(field, length(matched)),keywords[matched])},## Alternatively, generically use field mapped to title## case.name = {matched <- search_fun(dbBase$Name)search_db_results(matched,rep.int("Name", length(matched)),dbBase$Name[matched])},title = {matched <- search_fun(dbBase$Title)search_db_results(matched,rep.int("Title", length(matched)),dbBase$Title[matched])})}matches <- NULLfor(f in fields)matches <- rbind(matches, search_db_field(f))matches <- matches[order(matches$Position), ]db <- cbind(dbBase[matches$Position,c("Topic", "Title", "Name", "ID","Package", "LibPath", "Type"),drop = FALSE],matches[c("Field", "Entry")])rownames(db) <- NULLif(verbose>= 2L) {n_of_objects_matched <- length(unique(db[, "ID"]))message(sprintf(ngettext(n_of_objects_matched,"matched %d object.","matched %d objects."),n_of_objects_matched),domain = NA)flush.console()}## Retval.y <- list(pattern = pattern, fields = fields,type = if(fuzzy) "fuzzy" else "regexp",agrep = agrep,ignore.case = ignore.case, types = types,package = package, lib.loc = lib.loc,matches = db)class(y) <- "hsearch"y}hsearch_db <-function(package = NULL, lib.loc = NULL,types = getOption("help.search.types"),verbose = getOption("verbose"),rebuild = FALSE, use_UTF8 = FALSE){WINDOWS <- .Platform$OS.type == "windows"if(is.logical(verbose)) verbose <- 2 * as.integer(verbose)if(is.null(lib.loc))lib.loc <- .libPaths()i <- pmatch(types, hsearch_db_types)if (anyNA(i))stop("incorrect type specification")elsetypes <- hsearch_db_types[i]db <- eval(.hsearch_db())if(is.null(db))rebuild <- TRUEelse if(!rebuild) {## Need to find out whether this has the info we need.## Note that when looking for packages in libraries we always## use the first location found. Hence if the library search## path changes we might find different versions of a package.## Thus we need to rebuild the hsearch db in case the specified## library path is different from the one used when building the## hsearch db (stored as its "LibPaths" attribute).if(!identical(lib.loc, attr(db, "LibPaths")) ||anyNA(match(types, attr(db, "Types"))) ||## We also need to rebuild the hsearch db in case an existing## dir in the library path was modified more recently than## the db, as packages might have been installed or removed.any(attr(db, "mtime") < file.mtime(lib.loc[file.exists(lib.loc)])) ||## Or if the user changed the locale character type ...!identical(attr(db, "ctype"), Sys.getlocale("LC_CTYPE")))rebuild <- TRUE## We also need to rebuild if 'packages' was used before and has## changed.if(!is.null(package) &&any(is.na(match(package, db$Base[, "Package"]))))rebuild <- TRUE}if(rebuild) {if(verbose > 0L) {message("Rebuilding the help.search() database", " ", "...",if(verbose > 1L) "...", domain = NA)flush.console()}want_type_help <- any(types == "help")want_type_demo <- any(types == "demo")want_type_vignette <- any(types == "vignette")if(!is.null(package)) {packages_in_hsearch_db <- packagepackage_paths <- NULL} else {## local version of .packages(all.available = TRUE),## recording pathsans <- character(0L); paths <- character(0L)lib.loc <- lib.loc[file.exists(lib.loc)]valid_package_version_regexp <-.standard_regexps()$valid_package_versionfor (lib in lib.loc) {a <- list.files(lib, all.files = FALSE, full.names = FALSE)for (nam in a) {pfile <- file.path(lib, nam, "Meta", "package.rds")if (file.exists(pfile))info <- readRDS(pfile)$DESCRIPTION[c("Package", "Version")]else nextif ( (length(info) != 2L) || anyNA(info) ) nextif (!grepl(valid_package_version_regexp, info["Version"])) nextans <- c(ans, nam)paths <- c(paths, file.path(lib, nam))}}un <- !duplicated(ans)packages_in_hsearch_db <- ans[un]package_paths <- paths[un]names(package_paths) <- ans[un]}## Create the hsearch db.np <- 0Lif(verbose >= 2L) {message("Packages {readRDS() sequentially}:", domain = NA)flush.console()}tot <- length(package_paths)incr <- 0Lif(verbose && WINDOWS) {pb <- winProgressBar("R: creating the help.search() DB", max = tot)on.exit(close(pb))} else if(verbose == 1L) incr <- ifelse(tot > 500L, 100L, 10L)## Starting with R 1.8.0, prebuilt hsearch indices are available## in Meta/hsearch.rds, and the code to build this from the Rd## contents (as obtained from both new and old style Rd indices)## has been moved to tools:::.build_hsearch_index() which## creates a per-package list of base, aliases and keywords## information. When building the global index, it seems (see## e.g. also the code in tools:::Rdcontents()), most efficient to## create a list *matrix* (dbMat below), stuff the individual## indices into its rows, and finally create the base, alias,## keyword, and concept information in rbind() calls on the## columns. This is *much* more efficient than building## incrementally.dbMat <- vector("list", length(packages_in_hsearch_db) * 4L)dim(dbMat) <- c(length(packages_in_hsearch_db), 4L)## Empty hsearch index:hDB0 <- tools:::.build_hsearch_index(NULL)for(p in packages_in_hsearch_db) {if(incr && np %% incr == 0L) {message(".", appendLF = FALSE, domain = NA)flush.console()}np <- np + 1Lif(verbose && WINDOWS) setWinProgressBar(pb, np)if(verbose >= 2L) {message(" ", p, appendLF = ((np %% 5L) == 0L), domain=NA)flush.console()}path <- if(!is.null(package_paths)) package_paths[p]else find.package(p, lib.loc, quiet = TRUE)if(length(path) == 0L) {if(is.null(package)) nextelse stop(packageNotFoundError(p, lib.loc, sys.call()))}## Hsearch 'Meta/hsearch.rds' indices were introduced in## R 1.8.0. If they are missing, we really cannot use## the package (as library() will refuse to load it).## We always load hsearch.rds to establish the format,## sometimes vignette.rds.hDB <- NULLif(want_type_help) {if(file.exists(hs_file <-file.path(path, "Meta", "hsearch.rds"))) {hDB <- readRDS(hs_file)if(!is.null(hDB)) {## Fill up possibly missing information.if(is.na(match("Encoding", colnames(hDB[[1L]]))))hDB[[1L]] <- cbind(hDB[[1L]], Encoding = "")## <FIXME>## Transition fro old-style to new-style colnames.## Remove eventually.for(i in seq_along(hDB)) {colnames(hDB[[i]]) <-tools:::hsearch_index_colnames[[i]]}## </FIXME>} else if(verbose >= 2L) {message(gettextf("package %s has empty hsearch data - strangely",sQuote(p)),domain = NA)flush.console()}} else if(!is.null(package))warning("no hsearch.rds meta data for package ", p,domain = NA)}if(is.null(hDB))hDB <- hDB0nh <- NROW(hDB[[1L]])hDB[[1L]] <- cbind(hDB[[1L]], Type = rep.int("help", nh))if(nh)hDB[[1L]][, "LibPath"] <- pathif(want_type_vignette)hDB <- merge_vignette_index(hDB, path, p)if(want_type_demo)hDB <- merge_demo_index(hDB, path, p)## Put the hsearch index for the np-th package into the## np-th row of the matrix used for aggregating.dbMat[np, seq_along(hDB)] <- hDB}if(verbose >= 2L) {message(ifelse(np %% 5L == 0L, "\n", "\n\n"),sprintf("Built dbMat[%d,%d]", nrow(dbMat), ncol(dbMat)),domain = NA)flush.console()## DEBUG save(dbMat, file="~/R/hsearch_dbMat.rda", compress=TRUE)}## Create the global base, aliases, keywords and concepts tables## via calls to rbind() on the columns of the matrix used for## aggregating.db <- list(Base = do.call(rbind, dbMat[, 1]),Aliases = do.call(rbind, dbMat[, 2]),Keywords = do.call(rbind, dbMat[, 3]),Concepts = do.call(rbind, dbMat[, 4]))rownames(db$Base) <- NULL## <FIXME>## Remove eventually ...if(is.null(db$Concepts)) {db$Concepts <-matrix(character(), ncol = 3L,dimnames =list(NULL,tools:::hsearch_index_colnames$Concepts))}## </FIXME>## Make the IDs globally unique by prefixing them with the## number of the package in the global index.for(i in which(vapply(db, NROW, 0L) > 0L)) {db[[i]][, "ID"] <-paste(rep.int(seq_along(packages_in_hsearch_db),vapply(dbMat[, i], NROW, 0L)),db[[i]][, "ID"],sep = "/")}## And maybe re-encode ...if(!identical(Sys.getlocale("LC_CTYPE"), "C")) {if(verbose >= 2L) {message("reencoding ...", appendLF = FALSE, domain = NA)flush.console()}encoding <- db$Base[, "Encoding"]target <- ifelse(use_UTF8 && !l10n_info()$`UTF-8`, "UTF-8", "")## As iconv is not vectorized in the 'from' argument, loop## over groups of identical encodings.for(enc in unique(encoding)) {if(enc != target) nextIDs <- db$Base[encoding == enc, "ID"]for(i in seq_along(db)) {ind <- db[[i]][, "ID"] %in% IDsdb[[i]][ind, ] <- iconv(db[[i]][ind, ], enc, "")}}if(verbose >= 2L) {message(" ", "done", domain = NA)flush.console()}}bad_IDs <-unlist(lapply(db,function(u)u[rowSums(is.na(nchar(u, "chars",allowNA = TRUE,keepNA = FALSE))) > 0,"ID"]))## FIXME: drop this fallbackif(length(bad_IDs)) { # try latin1for(i in seq_along(db)) {ind <- db[[i]][, "ID"] %in% bad_IDsdb[[i]][ind, ] <- iconv(db[[i]][ind, ], "latin1", "")}bad_IDs <-unlist(lapply(db,function(u)u[rowSums(is.na(nchar(u, "chars",allowNA = TRUE,keepNA = FALSE))) > 0,"ID"]))}## If there are any invalid multi-byte character data## left, we simple remove all Rd objects with at least one## invalid entry, and warn.if(length(bad_IDs)) {warning("removing all entries with invalid multi-byte character data")for(i in seq_along(db)) {ind <- db[[i]][, "ID"] %in% bad_IDsdb[[i]] <- db[[i]][!ind, , drop = FALSE]}}## Drop entries without topic as these cannot be accessed.## (These come from help pages without \alias.)bad_IDs <- db$Base[is.na(db$Base[, "Topic"]), "ID"]if(length(bad_IDs)) {for(i in seq_along(db)) {ind <- db[[i]][, "ID"] %in% bad_IDsdb[[i]] <- db[[i]][!ind, , drop = FALSE]}}## Remove keywords which are empty.ind <- nzchar(db$Keywords[, "Keyword"])db$Keywords <- db$Keywords[ind, , drop = FALSE]## Remove concepts which are empty.ind <- nzchar(db$Concepts[, "Concept"])db$Concepts <- db$Concepts[ind, , drop = FALSE]## Map non-standard keywords to concepts, and use the## descriptions of the standard keywords as concepts, with the## exception of keyword 'internal'.standard <- .get_standard_Rd_keywords_with_descriptions()keywords <- standard$Keywordsconcepts <- standard$Descriptionspos <- match(db$Keywords[, "Keyword"], keywords)ind <- !is.na(pos) & (keywords[pos] != "internal")db$Concepts <-rbind(db$Concepts,db$Keywords[is.na(pos), , drop = FALSE],cbind(concepts[pos[ind]],db$Keywords[ind, -1L, drop = FALSE]))db$Keywords <- db$Keywords[!is.na(pos), , drop = FALSE]## Doing this earlier will not work: in particular, re-encoding## is written for character matrices.db <- lapply(db, as.data.frame,stringsAsFactors = FALSE, row.names = NULL)if(verbose >= 2L) {message("saving the database ...", appendLF = FALSE, domain = NA)flush.console()}attr(db, "LibPaths") <- lib.locattr(db, "mtime") <- Sys.time()attr(db, "ctype") <- Sys.getlocale("LC_CTYPE")attr(db, "Types") <- unique(c("help", types))class(db) <- "hsearch_db".hsearch_db(db)if(verbose >= 2L) {message(" ", "done", domain = NA)flush.console()}if(verbose > 0L) {message("... database rebuilt", domain = NA)if(WINDOWS) {close(pb)on.exit() # clear closing of progress bar}flush.console()}}db}## Cf. tools:::.get_standard_Rd_keywords()..get_standard_Rd_keywords_with_descriptions <-function(){lines <- readLines(file.path(R.home("doc"), "KEYWORDS.db"))## Strip top-level entries.lines <- grep("^.*\\|([^:]*):.*", lines, value = TRUE)## Strip comments.lines <- sub("[[:space:]]*#.*", "", lines)list(Keywords = sub("^.*\\|([^:]*):.*", "\\1", lines),Descriptions = sub(".*:[[:space:]]*", "", lines))}## This extra indirection allows the Mac GUI to replace this## yet call the printhsearchInternal function.print.hsearch <-function(x, ...)printhsearchInternal(x, ...)printhsearchInternal <-function(x, ...){help_type <- getOption("help_type", default = "text")types <- x$typesif (help_type == "html") {browser <- getOption("browser")port <- tools::startDynamicHelp(NA)if (port > 0L) {tools:::.httpd_objects(port, x)url <- sprintf("http://127.0.0.1:%d/doc/html/Search?objects=1&port=%d",port, port)## <NOTE>## Older versions used the following, which invokes the## dynamic HTML help system in a way that this calls## help.search() to give the results to be displayed.## This is now avoided by passing the (already available)## results to the dynamic help system using the dynamic## variable .httpd_objects().## url <-## paste0("http://127.0.0.1:", port,## "/doc/html/Search?pattern=",## tools:::escapeAmpersand(x$pattern),## paste0("&fields.", x$fields, "=1",## collapse = ""),## if (!is.null(x$agrep)) paste0("&agrep=", x$agrep),## if (!x$ignore.case) "&ignore.case=0",## if (!identical(types,## getOption("help.search.types")))## paste0("&types.", types, "=1",## collapse = ""),## if (!is.null(x$package))## paste0("&package=",## paste(x$package, collapse=";")),## if (!identical(x$lib.loc, .libPaths()))## paste0("&lib.loc=",## paste(x$lib.loc, collapse=";"))## )## </NOTE>browseURL(url, browser)return(invisible(x))}}hfields <- paste(x$fields, collapse = " or ")vfieldnames <-c(alias = "name", concept = "keyword", keyword = NA,name = "name", title = "title")vfieldnames <- vfieldnames[x$fields]vfields <- paste(unique(vfieldnames[!is.na(vfieldnames)]),collapse = " or ")dfieldnames <-c(alias = "name", concept = NA, keyword = NA,name = "name", title = "title")dfieldnames <- dfieldnames[x$fields]dfields <- paste(unique(dfieldnames[!is.na(dfieldnames)]),collapse = " or ")fields_used <-list(help = hfields, vignette = vfields, demo = dfields)matchtype <- switch(x$type, fuzzy = "fuzzy", "regular expression")typenames <-c(vignette = "Vignettes", help = "Help files", demo = "Demos")fields_for_match_details <-list(help = c("alias", "concept", "keyword"),vignette = c("concept"),demo = character())field_names_for_details <-c(alias = "Aliases", concept = "Concepts", keyword = "Keywords")db <- x$matchesif(NROW(db) == 0) {typenames <- paste(tolower(typenames[types]), collapse= " or ")writeLines(strwrap(paste("No", typenames,"found with", fields_used$help,"matching", sQuote(x$pattern),"using", matchtype,"matching.")))return(invisible(x))}outFile <- tempfile()outConn <- file(outFile, open = "w")typeinstruct <-c(vignette =paste("Type 'vignette(PKG::FOO)' to","inspect entries 'PKG::FOO'."),help =paste("Type '?PKG::FOO' to","inspect entries 'PKG::FOO',","or 'TYPE?PKG::FOO' for entries like","'PKG::FOO-TYPE'."),demo =paste("Type 'demo(PKG::FOO)' to","run demonstration 'PKG::FOO'."))for(type in types) {if(NROW(dbtemp <- db[db[, "Type"] == type, , drop = FALSE]) > 0) {writeLines(c(strwrap(paste(typenames[type], "with",fields_used[[type]], "matching",sQuote(x$pattern), "using",matchtype, "matching:")),"\n"),outConn)top <- dbtemp[ , "Topic"]ind <- (top != make.names(top))if(type == "help")ind <- ind & !grepl("-(class|method|package)$", top)top[ind] <- paste0("`", top[ind], "`")fields <- fields_for_match_details[[type]]chunks <- split.data.frame(dbtemp,paste0(dbtemp[, "Package"],"::",top))nms <- names(chunks)for(i in seq_along(nms)) {chunk <- chunks[[i]]writeLines(formatDL(nms[i], chunk[1L, "Title"]),outConn)matches <- Filter(length,split(chunk[, "Entry"],chunk[, "Field"])[fields])if(length(matches)) {tags <- field_names_for_details[names(matches)]vals <- vapply(matches, paste, "", collapse = ", ")writeLines(strwrap(paste0(tags, ": ", vals),indent = 2L, exdent = 4L),outConn)}}writeLines(c("\n",strwrap(typeinstruct[type]),"\n\n"),outConn)}}close(outConn)file.show(outFile, delete.file = TRUE)invisible(x)}hsearch_db_concepts <-function(db = hsearch_db()){## <NOTE>## This should perhaps get an ignore.case = TRUE argument.## </NOTE>pos <- match(db$Concepts[, "ID"], db$Base[, "ID"])entries <- split(as.data.frame(db$Base[pos, ],stringsAsFactors = FALSE),db$Concepts[, "Concept"])enums <- vapply(entries, NROW, 0L)pnums <- vapply(entries, function(e) length(unique(e$Package)), 0L)pos <- order(enums, pnums, decreasing = TRUE)list2DF(list(Concept = names(entries)[pos],Frequency = enums[pos],Packages = pnums[pos]))}hsearch_db_keywords <-function(db = hsearch_db()){pos <- match(db$Keywords[, "ID"], db$Base[, "ID"])entries <- split(as.data.frame(db$Base[pos, ],stringsAsFactors = FALSE),db$Keywords[, "Keyword"])enums <- vapply(entries, NROW, 0L)pnums <- vapply(entries, function(e) length(unique(e$Package)), 0L)standard <- .get_standard_Rd_keywords_with_descriptions()concepts <- standard$Descriptions[match(names(entries),standard$Keywords)]pos <- order(enums, pnums, decreasing = TRUE)list2DF(list(Keyword = names(entries)[pos],Concept = concepts[pos],Frequency = enums[pos],Packages = pnums[pos]))}print.hsearch_db <-function(x, ...){writeLines(c("A help search database:",sprintf("Objects: %d, Aliases: %d, Keywords: %d, Concepts: %d",NROW(x$Base),NROW(x$Aliases),NROW(x$Keywords),NROW(x$Concepts))))invisible(x)}