| #=============================================================================# |
| # Copyright (c) 2009, 2018 Stephan Wahlbrink and others. |
| # |
| # This program and the accompanying materials are made available under the |
| # terms of the Eclipse Public License 2.0 which is available at |
| # https://www.eclipse.org/legal/epl-2.0, or the Apache License, Version 2.0 |
| # which is available at https://www.apache.org/licenses/LICENSE-2.0. |
| # |
| # SPDX-License-Identifier: EPL-2.0 OR Apache-2.0 |
| # |
| # Contributors: |
| # Stephan Wahlbrink <sw@wahlbrink.eu> - initial API and implementation |
| #=============================================================================# |
| |
| |
| ## StatET help |
| |
| .getHelpFile <- function(file) { |
| path <- dirname(file) |
| dirpath <- dirname(path) |
| if(!file.exists(dirpath)) |
| stop(gettextf("invalid '%s' argument", "file"), domain= NA) |
| pkgname <- basename(dirpath) |
| RdDB <- file.path(path, pkgname) |
| if(!file.exists(paste(RdDB, "rdx", sep= "."))) |
| stop(gettextf("package %s exists but was not installed under R >= 2.10.0 so help cannot be accessed", sQuote(pkgname)), domain= NA) |
| tools:::fetchRdDB(RdDB, basename(file)) |
| } |
| |
| #' Creates rhelp url, mostly compatible to \code{help} |
| #' |
| #' @param topic |
| #' @param package |
| #' @param ... for compatibility |
| #' @returnType character |
| #' @return URL in rhelp schema |
| .getRHelpUrl <- function(helpObj) { |
| if (inherits(helpObj, "packageInfo")) { |
| return (paste("rhelp:///page", helpObj$name, "", sep= "/")) |
| } |
| if (inherits(helpObj, "help_files_with_topic")) { |
| topic <- attr(helpObj, "topic", exact= TRUE) |
| if (is.null(topic)) { |
| topic <- "help" |
| package <- "utils" |
| } |
| else { |
| package <- attr(helpObj, "call", exact= TRUE)[["package"]] |
| } |
| if (is.name(y <- substitute(package))) { |
| package <- as.character(y) |
| } |
| if (is.character(package) |
| && length(package) == 1 && !is.na(package)) { |
| return (paste("rhelp:///page", package, topic, sep= "/")) |
| } |
| else { |
| return (paste("rhelp:///topic", topic, sep= "/")) |
| } |
| } |
| stop("Unexpected help information.") |
| } |
| |
| #' Creates HTML help page for the given help page(s). |
| #' |
| #' @param x vector of help pages (as returns by original \code{help} |
| #' @return HTML page for a single page, otherwise \code{NULL} |
| #' @returnType character |
| .getLiveHelp <- function(x) { |
| paths <- as.character(x) |
| if(!length(paths)) { |
| writeLines(c(gettextf("No documentation for '%s' in specified packages and libraries:", |
| topic), |
| gettextf("you could try '??%s'", |
| topic))) |
| return (invisible(NULL)) |
| } |
| |
| if (attr(x, "tried_all_packages", exact= TRUE)) { |
| paths <- unique(dirname(dirname(paths))) |
| msg <- gettextf("Help for topic '%s' is not in any loaded package but can be found in the following packages:", |
| topic) |
| writeLines(c(strwrap(msg), "", |
| paste(" ", formatDL(c(gettext("Package"), basename(paths)), |
| c(gettext("Library"), dirname(paths)), |
| indent= 22)))) |
| return (invisible(NULL)) |
| } |
| |
| file <- NULL |
| if (length(paths) > 1L) { |
| p <- paths |
| msg <- gettextf("Help on topic '%s' was found in the following packages:", |
| topic) |
| paths <- dirname(dirname(paths)) |
| txt <- formatDL(c("Package", basename(paths)), |
| c("Library", dirname(paths)), |
| indent= 22L) |
| writeLines(c(strwrap(msg), "", paste(" ", txt), "")) |
| if (interactive()) { |
| fp <- file.path(paths, "Meta", "Rd.rds") |
| tp <- basename(p) |
| titles <- tp |
| if(type == "html" || type == "latex") |
| tp <- tools::file_path_sans_ext(tp) |
| for (i in seq_along(fp)) { |
| tmp <- try(.readRDS(fp[i])) |
| titles[i] <- if(inherits(tmp, "try-error")) |
| "unknown title" else |
| tmp[tools::file_path_sans_ext(tmp$File) == tp[i], "Title"] |
| } |
| txt <- paste(titles, " {", basename(paths), "}", sep= "") |
| ## the default on menu() is currtently graphics = FALSE |
| res <- menu(txt, title= gettext("Choose one"), |
| graphics= getOption("menu.graphics")) |
| if (res > 0) { |
| file <- p[res] |
| } else { |
| file <- NULL |
| } |
| } else { |
| file <- paths[1L] |
| writeLines(gettext("\nUsing the first match ...")) |
| } |
| } else { |
| file <- paths |
| } |
| |
| if (is.null(file)) { |
| return (invisible(NULL)) |
| } |
| |
| file <- sub("/html/([^/]*)\\.html$", "/help/\\1", file) |
| if (getRversion() < "2.11.0") { |
| rd <- .getHelpFile(file) |
| } |
| else { |
| rd <- utils:::.getHelpFile(file) |
| } |
| |
| renderRd(rd, basename(dirname(dirname(file)))) |
| } |
| |
| .showHelp <- function(url) { |
| if (missing(url) || !is.character(url) || length(url) != 1) { |
| stop("Illegal argument: url") |
| } |
| .rj_ui.execCommand("r/showHelp", list( |
| url= url ), wait= FALSE) |
| } |
| |
| #' Shows R help in StatET. This is a console command for R help in StatET |
| #' mainly compatible to the original \code{help}. |
| #' |
| #' @seealso help |
| #' @export |
| statet.help <- function(topic, package= NULL, lib.loc= NULL, |
| verbose= getOption("verbose"), |
| try.all.packages= getOption("help.try.all.packages"), ..., |
| live= FALSE ) { |
| nextCall <- match.call(expand.dots= TRUE) |
| callName <- nextCall[[1]] |
| |
| if (is.null(nextCall$topic) && !is.null(nextCall$package)) { |
| packageInfo <- list(name= nextCall$package) |
| class(packageInfo) <- "packageInfo" |
| |
| result <- list(value= packageInfo, visible= TRUE) |
| } |
| else { |
| nextCall[[1]] <- substitute(utils::help) |
| nextCall$live <- NULL |
| nextCall$help_type <- "html" |
| |
| result <- withVisible(eval(nextCall, envir= parent.frame())) |
| |
| result.call <- attr(result$value, "call", exact= TRUE) |
| if (!is.null(result.call)) { |
| result.call[[1]] <- callName |
| attr(result$value, "call") <- result.call |
| } |
| |
| } |
| |
| if (live) { |
| help.statet <- .getLiveHelp(result$value) |
| if (!is.null(help.statet)) { |
| help.statet <- paste(help.statet, collapse= "\n") |
| help.statet <- paste("html:///", help.statet, sep= "") |
| } |
| } |
| else if (is.null(.rj.tmp$help) |
| || inherits(result$value, "packageInfo") ) { |
| help.statet <- .getRHelpUrl(result$value) |
| } |
| else { |
| return (resolveVisible(result)) |
| } |
| if (is.character(help.statet) && !is.na(help.statet)) { |
| .showHelp(help.statet) |
| } |
| return (invisible()) |
| } |
| |
| #' Shows the R help start page in StatET. This is a console command for R help in StatET |
| #' mainly compatible to the original \code{help.start}. |
| #' |
| #' At moment no argument functionality is supported. |
| #' |
| #' @param ... for compatibility |
| #' @seealso help.start |
| #' @export |
| statet.help.start <- function(...) { |
| .showHelp("rhelp:///") |
| return (invisible()) |
| } |
| |
| |
| statet.print.help <- function(x, ...) { |
| type <- attr(x, "type", exact= TRUE) |
| if (length(x) == 0 |
| || (!is.null(type) && type != "html") |
| || is.null(.rj.tmp$help) ) { |
| # NextMethod ? |
| return (utils:::print.help_files_with_topic(x, ...)) |
| } |
| help.statet <- .getRHelpUrl(x) |
| if (is.character(help.statet) |
| && length(help.statet) == 1 && !is.na(help.statet)) { |
| .showHelp(help.statet) |
| } |
| return (invisible(x)) |
| } |
