| # File src/library/utils/R/help.search.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 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 <- NULL |
| function(new) { |
| if(!missing(new)) |
| hdb <<- new |
| else |
| hdb |
| } |
| }) |
| |
| 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 inefficient |
| if(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 it |
| base <- matrix("", nrow = nrow(vDB), ncol = 8L) |
| colnames(base) <- colnames(hDB[[1L]]) |
| base[, "Package"] <- pkg |
| base[, "LibPath"] <- path |
| id <- as.character(1:nrow(vDB) + NROW(hDB[[1L]])) |
| base[, "ID"] <- id |
| base[, "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$Title |
| base[, "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"] <- id |
| aliases[, "Package"] <- pkg |
| hDB[[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"] <- pkg |
| hDB[[4L]] <- rbind(hDB[[4L]], keywords) |
| } |
| } |
| hDB |
| } |
| |
| merge_demo_index <- |
| function(hDB, path, pkg) |
| { |
| ## Demos in the hsearch index started in R 2.14.0 |
| if(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 it |
| base <- matrix("", nrow = nrow(dDB), ncol = 8L) |
| colnames(base) <- colnames(hDB[[1]]) |
| base[, "Package"] <- pkg |
| base[, "LibPath"] <- path |
| id <- as.character(1:nrow(dDB) + NROW(hDB[[1L]])) |
| base[, "ID"] <- id |
| base[, "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"] <- id |
| aliases[, "Package"] <- pkg |
| hDB[[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_args <- function(args) |
| gettextf("argument %s must be a single character string", sQuote(args)) |
| if(is.logical(verbose)) verbose <- 2 * as.integer(verbose) |
| fuzzy <- agrep |
| if(!missing(pattern)) { |
| if(!is.character(pattern) || (length(pattern) > 1L)) |
| stop(.wrong_args("pattern"), domain = NA) |
| i <- pmatch(fields, hsearch_db_fields) |
| if(anyNA(i)) |
| stop("incorrect field specification") |
| else |
| fields <- hsearch_db_fields[i] |
| } else if(!missing(apropos)) { |
| if(!is.character(apropos) || (length(apropos) > 1L)) |
| stop(.wrong_args("apropos"), domain = NA) |
| else { |
| pattern <- apropos |
| fields <- c("alias", "title") |
| } |
| } else if(!missing(keyword)) { |
| if(!is.character(keyword) || (length(keyword) > 1L)) |
| stop(.wrong_args("keyword"), domain = NA) |
| else { |
| pattern <- keyword |
| fields <- "keyword" |
| if(is.null(fuzzy)) fuzzy <- FALSE |
| } |
| } else if(!missing(whatis)) { |
| if(!is.character(whatis) || (length(whatis) > 1)) |
| stop(.wrong_args("whatis"), domain = NA) |
| else { |
| pattern <- whatis |
| fields <- "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") |
| else |
| types <- 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.0 |
| if(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 <- fuzzy |
| fuzzy <- TRUE |
| } |
| else |
| stop("incorrect 'agrep' specification") |
| |
| dbBase <- db$Base |
| search_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) |
| data.frame(Position = p, Field = f, Entry = e, |
| stringsAsFactors = FALSE) |
| search_db_field <- function(field) { |
| switch(field, |
| alias = { |
| aliases <- db$Aliases$Alias |
| matched <- search_fun(aliases) |
| search_db_results(match(db$Aliases$ID[matched], |
| dbBase$ID), |
| rep.int(field, length(matched)), |
| aliases[matched]) |
| }, |
| concept = { |
| concepts <- db$Concepts$Concept |
| matched <- search_fun(concepts) |
| search_db_results(match(db$Concepts$ID[matched], |
| dbBase$ID), |
| rep.int(field, length(matched)), |
| concepts[matched]) |
| }, |
| keyword = { |
| keywords <- db$Keywords$Keyword |
| matched <- 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 <- NULL |
| for(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) <- NULL |
| if(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") |
| else |
| types <- hsearch_db_types[i] |
| |
| db <- eval(.hsearch_db()) |
| if(is.null(db)) |
| rebuild <- TRUE |
| else 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")) || |
| any(is.na(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 <- package |
| package_paths <- NULL |
| } else { |
| ## local version of .packages(all.available = TRUE), |
| ## recording paths |
| ans <- character(0L); paths <- character(0L) |
| lib.loc <- lib.loc[file.exists(lib.loc)] |
| valid_package_version_regexp <- |
| .standard_regexps()$valid_package_version |
| for (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 next |
| if ( (length(info) != 2L) || anyNA(info) ) next |
| if (!grepl(valid_package_version_regexp, info["Version"])) next |
| ans <- 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 <- 0L |
| if(verbose >= 2L) { |
| message("Packages {readRDS() sequentially}:", domain = NA) |
| flush.console() |
| } |
| tot <- length(package_paths) |
| incr <- 0L |
| if(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 + 1L |
| if(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)) next |
| else 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 <- NULL |
| if(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 <- hDB0 |
| nh <- NROW(hDB[[1L]]) |
| hDB[[1L]] <- cbind(hDB[[1L]], Type = rep.int("help", nh)) |
| if(nh) |
| hDB[[1L]][, "LibPath"] <- path |
| if(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) next |
| IDs <- db$Base[encoding == enc, "ID"] |
| for(i in seq_along(db)) { |
| ind <- db[[i]][, "ID"] %in% IDs |
| db[[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 fallback |
| if(length(bad_IDs)) { # try latin1 |
| for(i in seq_along(db)) { |
| ind <- db[[i]][, "ID"] %in% bad_IDs |
| db[[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_IDs |
| db[[i]] <- db[[i]][!ind, ] |
| } |
| } |
| |
| ## 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_IDs |
| db[[i]] <- db[[i]][!ind, ] |
| } |
| } |
| |
| ## 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$Keywords |
| concepts <- standard$Descriptions |
| pos <- 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.loc |
| attr(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$types |
| if (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$matches |
| if(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(\"FOO\", package=\"PKG\")' 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) |
| fields <- fields_for_match_details[[type]] |
| chunks <- split.data.frame(dbtemp, |
| paste0(dbtemp[, "Package"], |
| "::", |
| dbtemp[ , "Topic"])) |
| 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) |
| data.frame(Concept = names(entries)[pos], |
| Frequency = enums[pos], |
| Packages = pnums[pos], |
| stringsAsFactors = FALSE, |
| row.names = NULL) |
| } |
| |
| 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) |
| data.frame(Keyword = names(entries)[pos], |
| Concept = concepts[pos], |
| Frequency = enums[pos], |
| Packages = pnums[pos], |
| stringsAsFactors = FALSE, |
| row.names = NULL) |
| } |
| |
| 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) |
| } |
