Run processes in background

.Rbuildignore

@@ -25,3 +25,5 @@ _\.new\.png$
 ^source$
 ^revdep
 ^revdep$
+^manifest.json$
+^\.rscignore$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: riskassessment
 Title: A web app designed to interface with the `riskmetric` package
-Version: 3.0.0.9014
+Version: 3.0.0.9015
 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"),
@@ -41,6 +41,7 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Imports: 
     bslib (>= 0.3.0),
+    callr,
     config (>= 0.3.1),
     cranlogs,
     DBI,

NAMESPACE

@@ -28,6 +28,7 @@ importFrom(RSQLite,sqliteCopyDatabase)
 importFrom(archive,archive)
 importFrom(archive,archive_read)
 importFrom(bslib,bs_theme)
+importFrom(callr,r_bg)
 importFrom(cranlogs,cran_downloads)
 importFrom(desc,desc_fields)
 importFrom(desc,desc_get_field)

NEWS.md

@@ -14,6 +14,7 @@
 * Shorten waiting time in code explorer/package explorer by reading tarballs in memory (#707)
 * Move package upload process to a function
 * Updated logo in reports to lighter version to match application UI
+* Run report building in background if several are being requested (#711)
 
 # riskassessment 3.0.0
 

R/global.R

@@ -42,6 +42,7 @@ utils::globalVariables(
     'downloads',
     'ea_v',
     'estimate',
+    'explore_metrics',
     'func',
     'have_changed',
     'Last modified',
@@ -69,6 +70,7 @@ utils::globalVariables(
     'rpt_choices',
     'score',
     'setNames',
+    'status',
     'succ_icon',
     'text',
     'token',

R/mod_downloadHandler_utils.R

@@ -0,0 +1,181 @@
+#' asynch 
+#'
+#' @description A utils function
+#'
+#' @return The return value, if any, from executing the utility.
+#'
+#' @noRd
+report_creation <- function(pkg_lst, metric_weights, report_format, report_includes, user,
+                            loaded2_db, repo_pkgs,
+                            db_name = golem::get_golem_options('assessment_db_name'),
+                            my_tempdir = tempdir(), updateProgress = NULL) {
+  n_pkgs <- length(pkg_lst)
+
+  if (report_format == "html") {
+
+    # https://github.com/rstudio/fontawesome/issues/99
+    # Here, we make sure user has a functional version of fontawesome
+    fa_v <- packageVersion("fontawesome")
+    if(fa_v == '0.4.0') {
+      msg1 <- "HTML reports will not render with {fontawesome} v0.4.0."
+      msg2 <- glue::glue("You currently have v{fa_v} installed. If the report download failed, please install a stable version. We recommend v0.5.0 or higher.")
+      warning(paste(msg1, msg2))
+      showModal(modalDialog(
+        size = "l",
+        title = h3(msg1, class = "mb-0 mt-0 txt-color"),
+        h5(msg2)
+      ))
+    }
+
+    Report <- file.path(my_tempdir, "reportHtml.Rmd")
+    file.copy(app_sys('report_downloads', 'reportHtml.Rmd'), Report, overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'raa-image.png'),
+              file.path(my_tempdir, 'raa-image.png'), overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'header.html'),
+              file.path(my_tempdir, 'header.html'), overwrite = TRUE)
+  } 
+  else if (report_format == "docx") { 
+    Report <- file.path(my_tempdir, "reportDocx.Rmd")
+    if (!dir.exists(file.path(my_tempdir, "images")))
+      dir.create(file.path(my_tempdir, "images"))
+    file.copy(app_sys('report_downloads', 'reportDocx.Rmd'),
+              Report,
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'header.docx'),
+              file.path(my_tempdir, 'header.docx'),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'read_html.lua'),
+              file.path(my_tempdir, "read_html.lua"), overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'images', 'user-tie.png'),
+              file.path(my_tempdir, "images", "user-tie.png"),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'images', 'user-shield.png'),
+              file.path(my_tempdir, "images", "user-shield.png"),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'images', 'calendar-alt.png'),
+              file.path(my_tempdir, "images", "calendar-alt.png"),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'raa-image.png'),
+              file.path(my_tempdir, 'raa-image.png'), overwrite = TRUE)
+  } 
+  else { 
+    Report <- file.path(my_tempdir, "reportPdf.Rmd")
+    if (!dir.exists(file.path(my_tempdir, "images")))
+      dir.create(file.path(my_tempdir, "images"))
+    file.copy(app_sys('report_downloads', 'reportPdf.Rmd'),
+              Report,
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'header.tex'),
+              file.path(my_tempdir, 'header.tex'),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'fancyhdr.sty'),
+              file.path(my_tempdir, 'fancyhdr.sty'),
+              overwrite = TRUE)              
+    file.copy(app_sys('report_downloads', 'read_html.lua'),
+              file.path(my_tempdir, "read_html.lua"), overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'images', 'user-tie.png'),
+              file.path(my_tempdir, "images", "user-tie.png"),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'images', 'user-shield.png'),
+              file.path(my_tempdir, "images", "user-shield.png"),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'images', 'calendar-alt.png'),
+              file.path(my_tempdir, "images", "calendar-alt.png"),
+              overwrite = TRUE)
+    file.copy(app_sys('report_downloads', 'raa-image.png'),
+              file.path(my_tempdir, 'raa-image.png'), overwrite = TRUE)
+  }
+
+  fs <- c()
+  for (i in 1:n_pkgs) {
+    if (is.function(updateProgress))
+      updateProgress(1, paste("Processing", pkg_lst[i]))
+    # Grab package name and version, then create filename and path.
+    # this_pkg <- "stringr" # for testing
+    selected_pkg <- get_pkg_info(pkg_lst[i], db_name)
+    this_pkg <- selected_pkg$name
+    this_ver <- selected_pkg$version
+    file_named <- glue::glue('{this_pkg}_{this_ver}_Risk_Assessment.{report_format}')
+    path <- file.path(my_tempdir, file_named)
+
+    pkg_list <- list(
+      id = selected_pkg$id,
+      name = selected_pkg$name,
+      version = selected_pkg$version,
+      date_added = selected_pkg$date_added,
+      title = selected_pkg$title,
+      decision = selected_pkg$decision,
+      description = selected_pkg$description,
+      author = selected_pkg$author,
+      maintainer = selected_pkg$maintainer,
+      license = selected_pkg$license,
+      published = selected_pkg$published_on,
+      score = selected_pkg$score
+    )
+
+    # gather comments data
+    overall_comments <- get_overall_comments(this_pkg, db_name)
+    pkg_summary <- get_pkg_summary(this_pkg, db_name)
+    mm_comments <- get_mm_comments(this_pkg, db_name)
+    cm_comments <- get_cm_comments(this_pkg, db_name)
+    se_comments <- get_se_comments(this_pkg, db_name)
+    fe_comments <- get_fe_comments(this_pkg, db_name)
+
+    # gather maint metrics & community metric data
+    mm_data <- get_metric_data(this_pkg, metric_class = "maintenance", db_name)
+    comm_data <- get_comm_data(this_pkg, db_name)
+    comm_cards <- build_comm_cards(comm_data, db_name)
+    downloads_plot <- build_comm_plotly(comm_data)
+    metric_tbl <- dbSelect("select * from metric", db_name = db_name)
+
+    dep_metrics <- get_depends_data(this_pkg, db_name = db_name)
+
+    dep_cards <- build_dep_cards(data = dep_metrics, loaded = loaded2_db$name, toggled = 0L)
+
+    dep_table <- 
+      if (nrow(dep_metrics) == 0) {
+        dplyr::tibble(package = character(), type = character(), version = character(), score = character())
+      } else {
+        purrr::map_df(dep_metrics$name, ~get_versnScore(.x, loaded2_db, repo_pkgs)) %>%
+          right_join(dep_metrics, by = "name") %>%
+          select(package, type, version, score) %>%
+          arrange(package, type) %>%
+          distinct()
+      }
+
+    # Render the report, passing parameters to the rmd file.
+    rmarkdown::render(
+        input = Report,
+        output_file = path,
+        clean = FALSE,
+        params = list(pkg = pkg_list,
+                      report_includes = report_includes,
+                      riskmetric_version = paste0(packageVersion("riskmetric")),
+                      app_version = golem::get_golem_options('app_version'),
+                      metric_weights = metric_weights,
+                      user_name = user$name,
+                      user_role = paste(user$role, collapse = ', '),
+                      overall_comments = overall_comments,
+                      pkg_summary = pkg_summary,
+                      mm_comments = mm_comments,
+                      cm_comments = cm_comments,
+                      se_comments = se_comments,
+                      fe_comments = fe_comments,
+                      maint_metrics = mm_data,
+                      com_metrics = comm_cards,
+                      com_metrics_raw = comm_data,
+                      downloads_plot_data = downloads_plot,
+                      dep_cards = dep_cards,
+                      dep_table = dep_table,
+                      metric_tbl = metric_tbl
+        )
+      )
+    fs <- c(fs, path)  # Save all the reports/
+  }
+
+  if (is.function(updateProgress))
+    updateProgress(1, "**Finished**")
+
+  fs
+}
+

R/utils_build_cards.R

@@ -50,7 +50,7 @@ metric_gauge <- function(score) { # could add id arg here
 #' @importFrom stats lm
 #' @keywords internal
 #' 
-build_comm_cards <- function(data){
+build_comm_cards <- function(data, db_name = golem::get_golem_options('assessment_db_name')){
 
   cards <- dplyr::tibble(
     name = character(),
@@ -119,7 +119,7 @@ build_comm_cards <- function(data){
 
 
   # pull in some riskmetric data
-  comm <- get_metric_data(data$id[1], metric_class = 'community', golem::get_golem_options('assessment_db_name'))
+  comm <- get_metric_data(data$id[1], metric_class = 'community', db_name)
 
 
   # get downloads in the last year
@@ -147,7 +147,7 @@ build_comm_cards <- function(data){
 
 
   # get reverse dependency info
-  rev_deps <- get_assess_blob(data$id[1])$reverse_dependencies[[1]]
+  rev_deps <- get_assess_blob(data$id[1], db_name)$reverse_dependencies[[1]]
 
   comm_rev <- comm %>% filter(name == "reverse_dependencies")
   # new

R/utils_get_db.R

@@ -18,6 +18,7 @@ dbSelect <- function(query, db_name = golem::get_golem_options('assessment_db_na
   errFlag <- FALSE
   con <- DBI::dbConnect(RSQLite::SQLite(), db_name)
 
+  RSQLite::sqliteSetBusyHandler(con, 3000)
   tryCatch(
     expr = {
       rs <- DBI::dbSendQuery(con, glue::glue_sql(query, .envir = .envir, .con = con))

R/utils_insert_db.R

@@ -21,6 +21,7 @@ dbUpdate <- function(command, db_name = golem::get_golem_options('assessment_db_
   errFlag <- FALSE
   con <- DBI::dbConnect(RSQLite::SQLite(), db_name)
 
+  RSQLite::sqliteSetBusyHandler(con, 3000)
   tryCatch({
     rs <- DBI::dbSendStatement(con, glue::glue_sql(command, .envir = .envir, .con = con))
     if (!is.null(params))

tests/testthat/test-downloadHandler.R

@@ -4,19 +4,27 @@ test_that("downloadHandler works", {
 
   expect_equal(app$get_value(input = "tabs"), "single")
   expect_equal(app$get_value(input = "downloadHandler_1-report_format"), "html")
+  app$click("downloadHandler_1-create_reports", timeout_ = 30*1000)
+  app$wait_for_idle()
   report <- app$get_download("downloadHandler_1-download_reports")
   expect_equal(tools::file_ext(report), "html")
 
   app$set_inputs(`downloadHandler_1-report_format` = "docx")
+  app$click("downloadHandler_1-create_reports", timeout_ = 30*1000)
+  app$wait_for_idle()
   report <- app$get_download("downloadHandler_1-download_reports")
   expect_equal(tools::file_ext(report), "docx")
 
   app$set_inputs(`downloadHandler_1-report_format` = "pdf")
+  app$click("downloadHandler_1-create_reports", timeout_ = 30*1000)
+  app$wait_for_idle()
   report <- app$get_download("downloadHandler_1-download_reports")
   expect_equal(tools::file_ext(report), "pdf")
 
   app$set_inputs(tabs = "multiple")
   expect_equal(app$get_value(input = "downloadHandler_2-report_format"), "html")
+  app$click("downloadHandler_2-create_reports", timeout_ = 30*1000)
+  app$wait_for_idle()
   report <- app$get_download("downloadHandler_2-download_reports")
   expect_equal(tools::file_ext(report), "zip")
 })

tests/testthat/test-reportPreview.R

@@ -36,6 +36,8 @@ test_that("Reactivity of reportPreview", {
   expect_equal(app$get_value(input = "reportPreview-downloadHandler-report_format"), "html")
 
   # download and check file type
+  app$click("reportPreview-downloadHandler-create_reports", timeout_ = 30*1000)
+  app$wait_for_idle()
   report <- app$get_download("reportPreview-downloadHandler-download_reports")
   app$wait_for_idle()