Merge pull request #51 from datacamp/cleanup2

Cleanup2

DESCRIPTION

@@ -2,8 +2,12 @@ Package: RDocumentation
 Type: Package
 Title: Integrate R with 'RDocumentation.org'
 Version: 0.7.1
-Author: Jonathan Cornelissen <[email protected]>
-Maintainer: Ludovic Vannoorenberghe <[email protected]>
+Authors@R: c(
+    person("Ludovic", "Vannoorenberghe", email = "[email protected]", role = "cre"),
+    person("Jonathan", "Cornelissen", email = "[email protected]", role = "aut"),
+    person("Hannes", "Buseyne", role = "ctb"),
+    person("Filip", "Schouwenaars", email = "[email protected]", role = "ctb")
+    )
 URL: https://www.rdocumentation.org, https://www.datacamp.com
 BugReports: https://github.com/datacamp/RDocumentation/issues
 Description: Wraps around the default help functionality in R. Instead of plain documentation files, documentation will now show up as it does on 'RDocumentation.org', a platform that shows R documentation from CRAN, GitHub and Bioconductor, together with informative stats to assess the package quality and possibilities to discuss packages.
@@ -15,5 +19,5 @@ Imports:
   utils,
   githubinstall
 RoxygenNote: 5.0.1
-Suggests: 
+Suggests:
   testthat

R/defaults.R

@@ -79,11 +79,13 @@ remove_from_profile <- function(the_line) {
 }
 
 ask_questions <- function() {
-  if (!is_autoload()) {
-    ask_autoload()
-  }
-  if (!is_override()) {
-    ask_override()
+  if (interactive()) {
+    if (!is_autoload()) {
+      ask_autoload()
+    }
+    if (!is_override()) {
+      ask_override()
+    }  
   }
 }
 

R/install.R

@@ -5,8 +5,8 @@ utils::globalVariables("biocLite")
 #' @param type the type of the package, type 1 means the package comes from CRAN, type 2 packages are from BioConductor, type 3 packages are from GitHub and type 4 packages are by default part of R.
 #' @examples
 #' \dontrun{
-#' install_package("dplyr", 1)
-#' install_package("RDocumentation", 3)
+#'   install_package("dplyr", 1)
+#'   install_package("RDocumentation", 3)
 #' }
 #' 
 #' @export
@@ -21,16 +21,16 @@ install_package <- function(mypkg, type){
   else if (type == 2) {
     # bioconductor
     source("https://bioconductor.org/biocLite.R")
-    if (!is.element(mypkg, installed.packages()[ ,1])){
+    if (!is.element(mypkg, installed.packages()[ ,1])) {
       biocLite(mypkg)
     } else {
       biocLite("BiocUpgrade")
     }
   } else if (type == 3) {
     githubinstall(mypkg)
   } else if (type == 4) {
-    cat("Can not install this package, you need to upgrade your R installation")
-  } else{
-    cat("Something went wrong, could not install this package")
+    cat("RDocumentation cannot install this package, you need to upgrade your R installation")
+  } else {
+    cat("RDocumentation could not install this package; something went wrong.")
   }
 } 

R/overrides.R

@@ -1,65 +1,3 @@
-browseUrl.help <- function(url, browser) {
-  body = list(package_name = get_package_from_URL(url), called_function = "find_package")
-  return (view_help(body, url, browser))
-}
-
-# Overwrites the class<- function, converts help answers to json and sends them to RDocumentation
-`.class.help<-` <- function(package, value) {
-  if (value == "help_files_with_topic") {
-    if (!exists("package_not_local", envir = environment(help)) || environment(help)$package_not_local == "") {
-      packages <- lapply(package,function(path) {
-        temp = strsplit(path, "/")[[1]]
-        return (temp[length(temp)-2])
-      })
-      topic_names <- lapply(package, function(path) {
-        temp = strsplit(path, "/")[[1]]
-        return (tail(temp, n = 1))
-      })
-    }
-    else {
-      packages <- environment(help)$package_not_local
-      topic_names <- ""
-    }     
-    body <- list(packages = as.character(paste(packages,sep = "",collapse = ",")), topic_names = as.character(paste(topic_names, sep = "", collapse = ",")),
-                call = as.character(paste(attributes(package)$call, sep = "", collapse = ",")), topic = as.character(attributes(package)$topic),
-                tried_all_packages = as.character(attributes(package)$tried_all_packages), help_type = as.character(attributes(package)$type), called_function="help")
-  } else {
-    hsearch_db_fields <- c("alias", "concept", "keyword", "name", "title")
-    elas_search_db_fields <- c("aliases","concept","keywords","name","title")
-    fields = lapply(package$fields, function(e){
-      return (elas_search_db_fields[which(hsearch_db_fields == e)])
-    })
-    body <- list(query = as.character(package[1]), fields = as.character(paste(fields, sep = "", collapse = ",")),
-                 type = as.character(package[3]), agrep = as.character(package[4]), ignore_case = as.character(package[5]),
-                 types = as.character(paste(package$types, sep = "", collapse = ",")), package = as.character(package[7]),
-                 matching_titles = as.character(gsub(" ", "", toString(unique(package$matches$Topic)), fixed = TRUE)),
-                 matching_packages = as.character(gsub(" ", "", toString(unique(package$matches$Package)), fixed = TRUE)), called_function="help_search")
-  }
-  return (view_help(body, package, value))
-}
-
-# This find.package replacement function makes sure we can save the packagename to search it online, instead of returning an error.
-find.package.help <- function(packages, lib, verbose = FALSE){
-    tryCatch({
-        return (base::find.package(packages, lib, verbose))
-        },
-    error = function(cond){
-        #because we go over functioncalls and need access in the other function, we need to store this information internally
-        assign("package_not_local", packages, envir = environment(help))
-        return ("")
-    })
-}
-
-# Prototype = childEnvironment of the utils-package environment
-prototype <- proto(environment(help), 
-                   browseURL = browseUrl.help, 
-                   `class<-` = `.class.help<-`, 
-                   find.package = find.package.help, 
-                   help = utils::help, 
-                   help.search = utils::help.search,
-                   `?` = utils::`?`)
-
-
 #' Documentation on RDocumentation or via the normal help system if offline
 #'
 #' Wrapper functions around the default help functions from the \code{utils} package. If online, you'll be redirected to RDocumentation. If you're offline, you'll fall back onto your locally installed documentation files.
@@ -73,42 +11,89 @@ prototype <- proto(environment(help),
 #' @export
 #' @importFrom proto proto
 #' @importFrom utils help
-help <- function(...){
-  if (is_override()) {
-    careful_return(with(prototype, help)(...))
-  } else {
-    utils::help(...)
-  }
+help <- function(...) {
+  mc <- match.call(utils::help)
+  topic <- as.character(mc$topic)
+  package <- as.character(mc$package)
+  paths <- tryCatch({
+    utils::help(...)  
+  }, error = function(e) {
+    if (grepl("there is no package called", e$message)) {
+      return(character(0))
+    } else {
+      stop(e)
+    }
+  })
+  tryCatch({
+    if (!isTRUE(is_override())) {
+      stop("rdocs not active")
+    }
+    get_help(paths, package, topic)
+  }, error = function(e) {
+    print(e)
+    paths
+  })
 }
 
 #' @rdname documentation
 #' @export
-#' @importFrom proto proto
-#' @importFrom utils help.search
-help.search <- function(...) {
-  if (is_override()) {
-    careful_return(with(prototype, help.search)(...))
-  } else {
-    utils::help.search(...)
-  }
+`?` <- function(...){
+  paths <- utils::`?`(...)
+  tryCatch({
+    if (!isTRUE(is_override())) {
+      stop("rdocs not active")
+    }
+    get_help(paths)
+  }, error = function(e) {
+    paths
+  })
 }
 
 #' @rdname documentation
 #' @export
-#' @importFrom proto proto
-`?` <- function(...){
-  if (is_override()) {
-    careful_return(with(prototype, `?`)(...))
-  } else {
-    utils::`?`(...)
-  }
+#' @importFrom utils help.search
+help.search <- function(...) {
+  paths <- utils::help.search(...)
+  tryCatch({
+    if (!isTRUE(is_override())) {
+      stop("rdocs not active")
+    }
+    get_help_search(paths)
+  }, error = function(e) {
+    paths
+  })
+}
+
+get_help_search <- function(paths) {
+  lut <- c(alias = "aliases", concept = "concept", keyword = "keywords", name = "name", title = "title")
+  body <- paths
+  body$fields <- concat(lut[body$fields])
+  body$matching_titles <- concat(unique(body$matches$Topic))
+  body$matching_packages <- concat(unique(body$matches$Package))
+  body$called_function <- "help_search"
+  body[c("lib.loc", "matches", "types", "package")] <- NULL
+  view_help(body)
 }
 
-careful_return <- function(x) {
-  if (length(x) == 0) {
-    return(invisible())
-  } else{
-    return(x)
+get_help <- function(paths, package = "", topic = "") {
+  if (!length(paths)) {
+    # no documentation found locally, use specified package and topic names
+    packages <- if (length(package) == 0) "" else package
+    topic_names <- ""
+    topic <- if (length(topic) == 0) "" else topic
+  } else {
+    # documentation was found
+    split <- strsplit(paths, "/")
+    packages <- sapply(split, function(x) return(x[length(x)-2]))
+    topic_names <- sapply(split, tail, n = 1)
+    topic <- attr(paths, "topic")
   }
+  body <- list(packages = concat(packages),
+               topic_names = concat(topic_names),
+               topic = topic,
+               called_function = "help")
+  view_help(body)
 }
 
+
+

R/utils.R

@@ -8,7 +8,7 @@ cred_path <- file.path(system.file(package = "RDocumentation"), "config", "creds
 #' @param pkg Name of the package
 #' @param version the latest version to be checked
 #' 
-#' @return 1 if the package is not installed; -1 if the package is not up to date; 0 if the package if the package is installed.
+#' @return 1 if the package is not installed; -1 if the package is not up to date; 0 if the package if the package is installed and up to date.
 #' 
 #' @examples
 #' \dontrun{
@@ -56,4 +56,8 @@ get_r_profile <- function(){
   }
   Rprofile <- file.path(Sys.getenv("HOME"), ".Rprofile")
   return (Rprofile)
-}
+}
+
+concat <- function(x) {
+  paste(x, collapse = ",")
+}

R/view_help.R

@@ -1,8 +1,6 @@
 #' View the help
 #' 
 #' @param body body of the POST request to RDocumentation
-#' @param arg1 Same as arg1 of utils function
-#' @param arg2 Same as arg2 of utils function
 #' 
 #' @details Leverage https://www.rdocumentation.org/packages/tools/versions/3.3.1/topics/startDynamicHelp to render html page into the help pane
 #' As the page are rendered by the internal RStudio Server, it tricks RStudio into thinking that page is from the same origin as the other elements
@@ -21,53 +19,27 @@
 #' @importFrom rjson toJSON
 #' @importFrom utils browseURL
 #' @importFrom utils read.table
-view_help <- function(body, arg1, arg2){
-
+view_help <- function(body){
   # create doc directory if doesn't exist yet
   dir.create(rdocs_dir, showWarnings = FALSE)
-
-  if ( exists("package_not_local", envir = prototype)) {
-    package_not_local <- prototype$package_not_local
-  } else {
-    package_not_local <- ""
+  go_to_url <- paste0(rdocs_url, "rstudio/view?viewer_pane=1")
+  resp <- POST(go_to_url,
+               add_headers(Accept = "text/html"),
+               user_agent("rstudio"),
+               config = (content_type_json()),
+               body = rjson::toJSON(body),
+               encode = "json",
+               timeout(getOption("RDocumentation.timeOut")))
+  if (status_code(resp) == 200) {
+    writeBin(content(resp, "raw"), html_file)
+    browser <- getOption("browser")
+    p <- tools::startDynamicHelp(NA)
+    url <- build_local_url(p)
+    browseURL(url, browser)
+    return(invisible())
+  } else{
+    stop("bad return status")
   }
-  assign("package_not_local", "", envir = prototype)
-
-  tryCatch({
-    go_to_url <- paste0(rdocs_url, "rstudio/view?viewer_pane=1")
-    resp <- POST(go_to_url,
-                 add_headers(Accept = "text/html"),
-                 user_agent("rstudio"),
-                 config = (content_type_json()),
-                 body = rjson::toJSON(body),
-                 encode = "json",
-                 timeout(getOption("RDocumentation.timeOut")))
-
-    if (status_code(resp) == 200) {
-      writeBin(content(resp, "raw"), html_file)
-      browser <- getOption("browser")
-      p <- tools::startDynamicHelp(NA)
-      url <- build_local_url(p)
-      browseURL(url, browser)
-      return(invisible())
-    } else{
-      stop("bad return status")
-    }
-  },
-  error = function(e){
-    if (package_not_local != "") {
-      stop(paste0("package ", package_not_local, " is not in your local library"))
-    }
-    if (body$called_function == "help" || body$called_function == "help_search") {
-      return(baseenv()$`class<-`(arg1, arg2))
-    } else if (body$called_function == "find_package") {
-      #this line will throw an error if the package does not exist before falling back on the original help function
-      base::find.package(get_package_from_URL(arg1))
-      return(utils::browseURL(arg1, arg2))
-    } else {
-      stop(e)
-    }
-  })
 }
 
 #' @importFrom httr parse_url
@@ -85,8 +57,10 @@ build_local_url <- function(p) {
   # If in RStudio, send along creds.
   if (nchar(Sys.getenv("RSTUDIO")) > 0 && file.exists(cred_path) && file.info(cred_path)$size > 0) {
     creds <- paste0(readLines(cred_path), collapse = "")
-    comps <- parse_url(paste0("?", creds))$query[c("sid")]
-    append <- c(append, paste0(names(comps), "=", unlist(comps, use.names = FALSE)))
+    if (creds != "") {
+      comps <- parse_url(paste0("?", creds))$query[c("sid")]
+      append <- c(append, paste0(names(comps), "=", unlist(comps, use.names = FALSE)))
+    }
   }
   url <- paste0(url, paste0(append, collapse = "&"))
   return(url)