Merge pull request #52 from IDEMSInternational/updates

Updates from checks()

DESCRIPTION

@@ -19,6 +19,7 @@ Imports:
   getPass,
   ggplot2,
   ggrepel,
+  gh,
   grDevices,
   gt,
   htmlwidgets,

NAMESPACE

@@ -13,6 +13,9 @@ export(drop_unused_levels)
 export(duplicated_cases)
 export(duplicated_count_index)
 export(frac10)
+export(frac100)
+export(frac20)
+export(frac_den)
 export(getExample)
 export(getRowHeadersWithText)
 export(get_column_attributes)

R/global.R

@@ -1,2 +1,2 @@
 utils::globalVariables(c("av_packs","fq","labels_label","data_unstacked",".","level.out",
-                         "index.search", "<<-"))
+                         "index.search", "<<-", "av_packs"))

R/group_functions.R

@@ -163,7 +163,7 @@ view_graph_object <- function(graph_object){
   }else{
     print(graph_object)
   }
-  dev.off() #todo. use graphics.off() which one is better?
+  grDevices::dev.off() #todo. use graphics.off() which one is better?
 
 
   #todo. should we use respective package "convenience" functions to save the objects as image files depending on the class names?
@@ -312,7 +312,7 @@ check_graph <- function(graph_object){
   if (is.null(out)) {
     out <- tryCatch({
       message("Recording plot")
-      recordPlot()
+      grDevices::recordPlot()
     },
     error = function(cond) {
       message("Graph object does not exist:")
@@ -474,6 +474,7 @@ get_vignette <- function (package = NULL, lib.loc = NULL, all = TRUE)
 #' @param searchText The text to search for.
 #' @param ignore_case Logical indicating whether to ignore case. Defaults to TRUE.
 #' @param use_regex Logical indicating whether to use regular expressions. Defaults to FALSE.
+#' @param match_entire_cell Logical indicating whether to match the entire cell.
 #' @return A character vector of row headers where the search text is found.
 #' @examples
 #' \dontrun{
@@ -558,7 +559,7 @@ getExample <- function (topic, package = NULL, lib.loc = NULL, character.only =
       topic <- deparse(topic)[1L]
   }
   pkgpaths <- find.package(package, lib.loc, verbose = verbose)
-  file <- utils:::index.search(topic, pkgpaths, firstOnly = TRUE)
+  file <- index.search(topic, pkgpaths, firstOnly = TRUE)
   if (!length(file)) {
     warning(gettextf("no help found for %s", sQuote(topic)),
             domain = NA)
@@ -570,7 +571,7 @@ getExample <- function (topic, package = NULL, lib.loc = NULL, character.only =
   pkgname <- basename(packagePath)
   lib <- dirname(packagePath)
   tf <- tempfile("Rex")
-  tools::Rd2ex(utils:::.getHelpFile(file), tf, commentDontrun = !run.dontrun,
+  tools::Rd2ex(getHelpFile(file), tf, commentDontrun = !run.dontrun,
                commentDonttest = !run.donttest)
   if (!file.exists(tf)) {
     if (give.lines)
@@ -666,7 +667,7 @@ check_github_repo <- function(owner = NULL, repo = NULL, url = NULL) {
     repo <- basename(url)
   }
   if (requireNamespace(repo, quietly = TRUE)) {
-    local_sha <- packageDescription(repo)$GithubSHA1
+    local_sha <- utils::packageDescription(repo)$GithubSHA1
     if (!is.null(local_sha)) {
       latest_commit <- tryCatch({
         response <- gh::gh("/repos/:owner/:repo/commits", owner = owner, repo = repo, .limit = 1)
@@ -709,8 +710,14 @@ check_github_repo <- function(owner = NULL, repo = NULL, url = NULL) {
 #'
 #' @export
 frac10 <- function(x) { paste0(round(x * 10), "/", 10) }
+#' @rdname frac10
+#' @export
 frac20 <- function(x) { paste0(round(x * 20), "/", 20) }
+#' @rdname frac10
+#' @export
 frac100 <- function(x) { paste0(round(x * 100), "/", 100) }
+#' @rdname frac10
+#' @export
 frac_den <- function(x, den) { paste0(round(x * den), "/", den) }
 
 #' Monitor Memory Usage
@@ -727,7 +734,7 @@ frac_den <- function(x, den) { paste0(round(x * den), "/", den) }
 #' @export
 monitor_memory <- function() {
   if (.Platform$OS.type == "windows") {
-    mem_used <- memory.size()
+    mem_used <- utils::memory.size()
   } else {
     mem_used <- sum(gc()[, "used"]) / 1024
   }

R/package_check.R

@@ -45,19 +45,19 @@ package_check <- function(package) {
     #CHECK the Package is a CRAN package	
     if (package %in% av_packs$Package){
       #PACKAGE IS INSTALLED 
-      if (package %in% rownames(installed.packages())){
+      if (package %in% rownames(utils::installed.packages())){
         out[[1]] <- "1"
-        v_machine <- as.character(packageVersion(package))
+        v_machine <- as.character(utils::packageVersion(package))
         v_web <- as.character(av_packs[av_packs$Package == package, "Version"])
-        out[[2]] <- compareVersion(v_machine, v_web)
+        out[[2]] <- utils::compareVersion(v_machine, v_web)
         out[[3]] <- v_machine
         out[[4]] <- v_web			
       }
       else  out[[1]] <- "2"	
     }
     else{
       #PACKAGE IS INSTALLED BUT NOT IN THE CRAN REPO
-      if (package %in% rownames(installed.packages())) out[[1]] <- "3"			
+      if (package %in% rownames(utils::installed.packages())) out[[1]] <- "3"			
       #PACKAGE IS NOT INSTALLED AND NOT IN THE CRAN REPO
       else out[[1]] <- "4"	
     }

R/unexported.R

@@ -0,0 +1,64 @@
+
+index.search <- function (topic, paths, firstOnly = FALSE) {
+  res <- character()
+  for (p in paths) {
+    if (file.exists(f <- file.path(p, "help", "aliases.rds"))) 
+      al <- readRDS(f)
+    else if (file.exists(f <- file.path(p, "help", "AnIndex"))) {
+      foo <- scan(f, what = list(a = "", b = ""), sep = "\t", 
+                  quote = "", na.strings = "", quiet = TRUE)
+      al <- structure(foo$b, names = foo$a)
+    }
+    else next
+    f <- al[topic]
+    if (is.na(f)) 
+      next
+    res <- c(res, file.path(p, "help", f))
+    if (firstOnly) 
+      break
+  }
+  res
+}
+
+getHelpFile <- function (file) 
+{
+  path <- dirname(file)
+  dirpath <- dirname(path)
+  if (!file.exists(dirpath)) 
+    stop(gettextf("invalid %s argument", sQuote("file")), 
+         domain = NA)
+  pkgname <- basename(dirpath)
+  RdDB <- file.path(path, pkgname)
+  if (!file.exists(paste0(RdDB, ".rdx"))) 
+    stop(gettextf("package %s exists but was not installed under R >= 2.10.0 so help cannot be accessed", 
+                  sQuote(pkgname)), domain = NA)
+  fetchRdDB(RdDB, basename(file))
+}
+
+fetchRdDB <- function (filebase, key = NULL) 
+{
+  fun <- function(db) {
+    vals <- db$vals
+    vars <- db$vars
+    datafile <- db$datafile
+    compressed <- db$compressed
+    envhook <- db$envhook
+    fetch <- function(key) lazyLoadDBfetch(vals[key][[1L]], 
+                                           datafile, compressed, envhook)
+    if (length(key)) {
+      if (key %notin% vars) 
+        stop(gettextf("No help on %s found in RdDB %s", 
+                      sQuote(key), sQuote(filebase)), domain = NA)
+      fetch(key)
+    }
+    else {
+      res <- lapply(vars, fetch)
+      names(res) <- vars
+      res
+    }
+  }
+  res <- lazyLoadDBexec(filebase, fun)
+  if (length(key)) 
+    res
+  else invisible(res)
+}