Merge pull request #756 from pharmaR/ni-707-add-waiting-screen

Ni 707 add waiting screen

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: riskassessment
 Title: A web app designed to interface with the `riskmetric` package
-Version: 3.0.0.9012
+Version: 3.0.0.9013
 Authors@R: c( 
     person("Aaron", "Clark", role = c("aut", "cre"), email = "aaron.clark@biogen.com"),
     person("Robert", "Krajcik", role = "aut", email = "robert.krajcik@biogen.com"),
@@ -68,7 +68,8 @@ Imports:
     shinyWidgets,
     stringr,
     shinyAce,
-    sortable
+    sortable,
+    archive
 Suggests: 
     chromote (>= 0.1.1.9001),
     fontawesome,

NAMESPACE

@@ -25,6 +25,8 @@ importFrom(DT,selectRows)
 importFrom(DT,styleEqual)
 importFrom(RSQLite,SQLite)
 importFrom(RSQLite,sqliteCopyDatabase)
+importFrom(archive,archive)
+importFrom(archive,archive_read)
 importFrom(bslib,bs_theme)
 importFrom(cranlogs,cran_downloads)
 importFrom(desc,desc_fields)

NEWS.md

@@ -11,6 +11,7 @@
 * Added dependencies/reverse dependencies card hyperlink (#597)
 * Added non-shinymanager deployment option (#700)
 * Added Package Dependencies to Reports (#721)
+* Shorten waiting time in code explorer/package explorer by reading tarballs in memory (#707)
 
 # riskassessment 3.0.0
 

R/app_server.R

@@ -245,35 +245,25 @@ app_server <- function(input, output, session) {
   })
 
   create_src_dir <- eventReactive(input$tabs, input$tabs == "Source Explorer")
-  pkgdir <- reactiveVal()
+  pkgarchive <- reactiveVal()
   observe({
     req(selected_pkg$name() != "-")
     req(create_src_dir())
     req(file.exists(file.path("tarballs", glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz"))))
-
-    src_dir <- file.path("source", selected_pkg$name())
-    if (dir.exists(src_dir)) {
-      pkgdir(src_dir)
-    } else {
-      withProgress(
-        utils::untar(file.path("tarballs", glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz")), exdir = "source"),
-        message = glue::glue("Unpacking {selected_pkg$name()}_{selected_pkg$version()}.tar.gz"),
-        value = 1
-      )
-      pkgdir(src_dir)
-    }
+    pkgarchive(archive::archive(file.path("tarballs", glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz"))) %>% 
+                 dplyr::arrange(tolower(path)))
   }) %>% 
     bindEvent(selected_pkg$name(), create_src_dir())
 
 
   mod_pkg_explorer_server("pkg_explorer", selected_pkg,
-                          pkgdir = pkgdir,
+                          pkgarchive = pkgarchive,
                           creating_dir = create_src_dir,
                           user = user,
                           credentials = credential_config)
 
   mod_code_explorer_server("code_explorer", selected_pkg,
-                          pkgdir = pkgdir,
+                           pkgarchive = pkgarchive,
                           creating_dir = create_src_dir,
                           user = user,
                           credentials = credential_config)

R/mod_code_explorer.R

@@ -11,14 +11,14 @@ mod_code_explorer_ui <- function(id){
   ns <- NS(id)
   uiOutput(ns("func_explorer_ui"))
 }
-
 #' code_explorer Server Functions
 #'
 #' @noRd 
 #' 
 #' @importFrom tools Rd2HTML
 #' @importFrom purrr map_dfr
-mod_code_explorer_server <- function(id, selected_pkg, pkgdir = reactiveVal(), creating_dir = reactiveVal(TRUE), user, credentials){
+#' @importFrom archive archive_read archive 
+mod_code_explorer_server <- function(id, selected_pkg, pkgarchive = reactiveVal(), creating_dir = reactiveVal(TRUE), user, credentials){
   moduleServer( id, function(input, output, session){
     ns <- session$ns
 
@@ -79,14 +79,15 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgdir = reactiveVal(), c
       }
     })
 
-    exported_functions <- eventReactive(pkgdir(), {
-      get_exported_functions(pkgdir())
+    exported_functions <- eventReactive(pkgarchive(), {
+      get_exported_functions(pkg_name = selected_pkg$name(), pkg_version = selected_pkg$version())
     })
 
     parse_data <- eventReactive(exported_functions(), {
+
       purrr::map_dfr(
         c("test", "source"),
-        ~ get_parse_data(.x, pkgdir(), exported_functions())
+        ~ get_parse_data(.x, pkgarchive(), pkg_name = selected_pkg$name(), pkg_version = selected_pkg$version(), exported_functions())
       )
     })
 
@@ -96,26 +97,36 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgdir = reactiveVal(), c
     observeEvent(input$exported_function, {
       req(input$exported_function)
       test_files(get_files(input$exported_function, "test", parse_data()))
-      updateSelectInput(session, "test_files", choices = test_files(),
-                        selected = if (!rlang::is_empty(test_files())) test_files()[1] else NULL)
+      updateSelectInput(session, "test_files", choices = basename(test_files()),
+                        selected = if (!rlang::is_empty(test_files())) basename(test_files())[1] else NULL)
 
       source_files(get_files(input$exported_function, "source", parse_data()))
-      updateSelectInput(session, "source_files", choices = source_files(),
-                        selected = if (!rlang::is_empty(source_files())) source_files()[1] else NULL)
+      updateSelectInput(session, "source_files", choices = basename(source_files()),
+                        selected = if (!rlang::is_empty(source_files())) basename(source_files())[1] else NULL)
 
-      man_files(get_files(input$exported_function, "man", pkgdir()))
-      updateSelectInput(session, "man_files", choices = man_files(),
-                        selected = if (!rlang::is_empty(man_files())) man_files()[1] else NULL)
+      man_files(get_files(input$exported_function, "man", pkgarchive(), pkg_name = selected_pkg$name(), pkg_version = selected_pkg$version()))
+      updateSelectInput(session, "man_files", choices = basename(man_files()),
+                        selected = if (!rlang::is_empty(man_files())) basename(man_files())[1] else NULL)
     })
 
     test_code <- reactive({
       if (rlang::is_empty(test_files())) return(HTML("No files to display"))
       req(input$test_files)
-      fp <- if (file.exists(file.path(pkgdir(), "tests", "testthat.R"))) file.path(pkgdir(), "tests", "testthat", input$test_files) else file.path(pkgdir(), "tests", input$test_files)
-      lines <- readLines(fp)
+      if (file.path(glue::glue("{selected_pkg$name()}"),"tests", "testthat.R") %in% pkgarchive()$path )
+        {
+        fp <-   file.path(glue::glue("{selected_pkg$name()}"), "tests", "testthat", input$test_files)}
+      else 
+      { 
+        fp <- file.path(glue::glue("{selected_pkg$name()}"), "tests", input$test_files) 
+        }
+      con <- archive::archive_read(file.path("tarballs",
+                                             glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz")),
+                                   file = fp)
+      lines <- readLines(con)
+      close(con)
       func_list <- c(input$exported_function, paste0("`", input$exported_function, "`"))
       highlight_index <- parse_data() %>% 
-        filter(file == input$test_files & func %in% func_list) %>% 
+        filter(stringr::str_ends(file, input$test_files) & func %in% func_list) %>% 
         pull(line)
       renderCode(lines, highlight_index)
     }) %>%
@@ -124,10 +135,15 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgdir = reactiveVal(), c
     source_code <- reactive({
       if (rlang::is_empty(source_files())) return(HTML("No files to display"))
       req(input$source_files)
-      lines <- readLines(file.path(pkgdir(), "R", input$source_files))
+      fp <- file.path(glue::glue("{selected_pkg$name()}"), "R", input$source_files) 
+      con <- archive::archive_read(file.path("tarballs",
+                                             glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz")),
+                                   file = fp)
+      lines <- readLines(con)
+      close(con)
       func_list <- c(input$exported_function, paste0("`", input$exported_function, "`"))
       highlight_index <- parse_data() %>% 
-        filter(file == input$source_files & func %in% func_list) %>% 
+        filter(stringr::str_ends(file, input$source_files) & func %in% func_list) %>% 
         pull(line)
       renderCode(lines, highlight_index)
     }) %>%
@@ -136,9 +152,15 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgdir = reactiveVal(), c
     man_page <- reactive({
       if (rlang::is_empty(man_files())) return(HTML("No files to display"))
       req(input$man_files)
-      out_dir <- tempdir()
-      tools::Rd2HTML(file.path(pkgdir(), "man", input$man_files), package = c(selected_pkg$name(), selected_pkg$version()), out = file.path(out_dir, "man.html"))
-      includeHTML(file.path(out_dir, "man.html"))
+      fp <- file.path(glue::glue("{selected_pkg$name()}"), "man", input$man_files) 
+      con <- archive::archive_read(file.path("tarballs",
+                                             glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz")),
+                                   file = fp)
+      Rdfile <-tools::parse_Rd(con)
+      close(con)
+      HTML(paste0(capture.output(tools::Rd2HTML(Rdfile,
+                                               package = c(selected_pkg$name(),
+                                                           selected_pkg$version()), out = "")), collapse = "\n"))
     }) %>%
       bindEvent(input$man_files, input$exported_function, ignoreNULL = FALSE)
 

R/mod_code_explorer_utils.R

@@ -2,14 +2,19 @@
 #' 
 #' Scrapes NAMESPACE for exported functions and returns them as a list
 #' 
-#' @param pkgdir The package directory to evaluate
+#' @param pkgArchive  The package directory to evaluate
 #' 
 #' @return A character vector of the function names
 #' 
 #' @noRd
-get_exported_functions <- function(pkgdir) {
-  nsFile <- parse(file.path(pkgdir, "NAMESPACE"), keep.source = FALSE, srcfile = NULL)
+get_exported_functions <- function(pkg_name, pkg_version) {
+
+ con <- archive::archive_read(file.path("tarballs",
+                                        glue::glue("{pkg_name}_{pkg_version}.tar.gz")),
+                              file = glue::glue("{pkg_name}/NAMESPACE"))
+  nsFile <- parse(con, keep.source = TRUE)
   nsexp <- character(); nsimp <- character()
+  close(con)
   for (e in nsFile) {
     switch (as.character(e[[1L]]),
       export = {
@@ -28,7 +33,7 @@ get_exported_functions <- function(pkgdir) {
 #' Parses the files to determine which contain the function(s) of interest
 #' 
 #' @param type The type of files to parse
-#' @param pkgdir The package directory
+#' @param pkgArchive   The package directory
 #' @param funcnames The list of functions to evaluate
 #' 
 #' @return A `tibble` object containing the type of file, file name, function,
@@ -37,17 +42,25 @@ get_exported_functions <- function(pkgdir) {
 #' @noRd
 #' 
 #' @importFrom utils getParseData
-get_parse_data <- function(type = c("test", "source"), pkgdir, funcnames = NULL) {
+get_parse_data <- function(type = c("test", "source"), pkgarchive, pkg_name, pkg_version, funcnames = NULL) {
+
   type <- match.arg(type)
   dirpath <- switch (type,
-    test = if (file.exists(file.path(pkgdir, "tests", "testthat.R"))) file.path(pkgdir, "tests", "testthat") else file.path(pkgdir, "tests"),
-    source = file.path(pkgdir, "R")
+    test = if (file.path(glue::glue("{pkg_name}"), "tests", "testthat.R") %in% pkgarchive$path ){
+      file.path(glue::glue("{pkg_name}"), "tests", "testthat") }
+    else { file.path(glue::glue("{pkg_name}"),"tests") }
+    ,
+    source = file.path(glue::glue("{pkg_name}"), "R")
   )
-  filenames <- list.files(dirpath, ".+\\.[R|r]$")
+  filenames <- na.omit((str_extract(pkgarchive$path,paste0(dirpath, ".+\\.[R|r]$"))))
   dplyr::bind_rows(lapply(filenames, function(filename) {
-    d <- parse(file.path(dirpath, filename), keep.source = TRUE) %>% 
+    con <- archive::archive_read(file.path("tarballs",
+                                           glue::glue("{pkg_name}_{pkg_version}.tar.gz")),
+                                 file = filename)
+    d <- parse(text = readLines(con), keep.source = TRUE)  %>%
       utils::getParseData() %>% 
       dplyr::filter(token %in% c("SYMBOL_FUNCTION_CALL", "SYMBOL", "SPECIAL", "STR_CONST"))
+    close(con)
     d <- d %>% 
       dplyr::mutate(
         type = type,
@@ -104,17 +117,23 @@ get_source_files <- function(funcname, parse_data) {
 #' Returns the man files from the package directory corresponding to the function of interest
 #' 
 #' @param funcname The name of the function to evaluate
-#' @param pkgdir The package directory
+#' @param pkgArchive   The package directory
 #' 
 #' @noRd
-get_man_files <- function(funcname, pkgdir) {
-  man_files <- list.files(file.path(pkgdir, "man"), ".+\\.Rd$")
+get_man_files <- function(funcname, pkgarchive, pkg_name, pkg_version) {
+
+  man_files <- na.omit((str_extract(pkgarchive$path,
+                                    paste(glue::glue("{pkg_name}"), "man", ".+\\.Rd$", sep ="/"))))
   funcname_regex <- 
     gsub("([.|()\\^{}+$*?]|\\[|\\])", "\\\\\\1", funcname) %>%
     gsub(pattern = "`", replacement = "`?") %>%
     gsub(pattern = "\\%", replacement = "\\\\\\\\\\%")
   i <- sapply(man_files, function(f) {
-    s <- readLines(file.path(pkgdir, "man", f))
+    con <- archive::archive_read(file.path("tarballs",
+                                           glue::glue("{pkg_name}_{pkg_version}.tar.gz")),
+                                 file = f)
+    s <- readLines(con)
+    close(con)
     any(grepl(sprintf("name\\{%s\\}|alias\\{%s\\}", funcname_regex, funcname_regex), s))
   })
   man_files[i]

R/mod_pkg_explorer.R

@@ -18,20 +18,20 @@ mod_pkg_explorer_ui <- function(id){
 #' @importFrom shinyAce updateAceEditor
 #' @importFrom utils untar
 #' @importFrom shinyTree shinyTree renderTree updateTree get_selected
+#' @importFrom archive archive_read archive 
 #'
 #' @noRd 
 mod_pkg_explorer_server <- function(id, selected_pkg,
                                     accepted_extensions = c("r", "rmd", "rd", "txt", "md","csv", "tsv", "json", "xml", "yaml", "yml", "dcf", "html", "js", "css", "c", "cpp", "h", "java", "scala", "py", "perl", "sh", "sql"),
                                     accepted_filenames = c("DESCRIPTION", "NAMESPACE", "LICENSE", "LICENSE.note", "NEWS", "README", "CHANGES", "MD5"),
-                                    pkgdir = reactiveVal(),
+                                    pkgarchive = reactiveVal(),
                                     creating_dir = reactiveVal(TRUE),
                                     user, credentials) {
   moduleServer( id, function(input, output, session){
     ns <- session$ns
 
     output$pkg_explorer_ui <- renderUI({
 
-
       # Lets the user know that a package needs to be selected.
       if(identical(selected_pkg$name(), character(0))) {
         showHelperMessage()
@@ -84,18 +84,24 @@ mod_pkg_explorer_server <- function(id, selected_pkg,
       bindEvent(selected_pkg$name(), creating_dir())
 
     nodes <- reactive({
-      req(pkgdir())
-      s <- make_nodes(list.files(pkgdir(), recursive = TRUE))
+      req(pkgarchive())
+      s <-  pkgarchive() %>%
+        filter(size > 0) %>%
+        filter(grepl("/", path))  %>%
+       dplyr::pull(path) %>%
+      make_nodes() %>%
+        .[[1]]
       if(!is.null(s[["DESCRIPTION"]])){
       attr(s[["DESCRIPTION"]],"stselected") = TRUE
       }
       else {
         f <- names(head(purrr::keep(s, \(x) !is.null(attr(x, "sttype"))), 1))
         attr(s[[f]],"stselected") = TRUE
       }
+
       s
     }) %>%
-      bindEvent(pkgdir(), selected_pkg$name())
+      bindEvent(pkgarchive (), selected_pkg$name())
 
     output$dirtree <- shinyTree::renderTree(nodes())
 
@@ -117,7 +123,11 @@ mod_pkg_explorer_server <- function(id, selected_pkg,
         filename <- basename(filepath)
         e <- tolower(tools::file_ext(filepath))
         if (e %in% accepted_extensions || filename %in% accepted_filenames) {
-          s <- readLines(file.path(pkgdir(), filepath))
+          con <- archive::archive_read(file.path("tarballs",
+                                                 glue::glue("{selected_pkg$name()}_{selected_pkg$version()}.tar.gz")),
+                                       file = glue::glue("{selected_pkg$name()}/{filepath}"))
+          s <- readLines(con)
+          close(con)
           s <- paste(s, collapse = "\n")
         } else {
           s <- "file format not supported"

renv.lock

@@ -195,6 +195,21 @@
       ],
       "Hash": "74a64813f17b492da9c6afda6b128e3d"
     },
+    "archive": {
+      "Package": "archive",
+      "Version": "1.1.5",
+      "Source": "Repository",
+      "Repository": "RSPM",
+      "Requirements": [
+        "R",
+        "cli",
+        "cpp11",
+        "glue",
+        "rlang",
+        "tibble"
+      ],
+      "Hash": "ed7b553d0142e37936e924b95c876cfe"
+    },
     "askpass": {
       "Package": "askpass",
       "Version": "1.1",