add progress indicator

.github/workflows/main.yaml

@@ -8,7 +8,7 @@ jobs:
         shell: Rscript {0}
     container:
       # update muggle here and in Dockerfile
-      image: subugoe/muggle-buildtime-onbuild:0.1.2-20210716
+      image: subugoe/muggle-buildtime-onbuild:0.1.2-20211124
     env:
       MUGGLE_PKG_NAME: ${{ github.event.repository.name }}
       GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: metacheck
 Title: Crossref Metadata Compliance
-Version: 0.3.0
+Version: 0.3.1.9000
 Authors@R:
     c(
       person(
@@ -85,7 +85,9 @@ Imports:
     bslib,
     curl,
     crlite,
-    lobstr
+    lobstr,
+    progressr,
+    ellipsis
 Suggests:
     testthat,
     subugoetheme,
@@ -95,7 +97,9 @@ Suggests:
     htmltools,
     knitr,
     pkgdown,
-    downlit
+    downlit,
+    remotes,
+    usethis
 URL: https://subugoe.github.io/metacheck, https://github.com/subugoe/metacheck
 BugReports: https://github.com/subugoe/metacheck/issues
 Remotes: 
@@ -109,4 +113,5 @@ Remotes:
     r-lib/downlit@47e30dbe7650bac683c979e73608180813ce660c
 Config/testthat/edition: 3
 Config/testthat/parallel: true
+Config/testthat/start-first: communicate, email, import
 Config/wama/defaultShinyApp: mcApp()

Dockerfile

@@ -1,4 +1,5 @@
-ARG MUGGLE_TAG=0.1.2-20210716
+ARG MUGGLE_TAG=0.1.2-20211124
 FROM subugoe/muggle-buildtime-onbuild:${MUGGLE_TAG} as buildtime
 FROM subugoe/muggle-runtime-onbuild:${MUGGLE_TAG} as runtime
+ENV R_FUTURE_PLAN=multicore
 CMD shinycaas::shiny_opts_az(); metacheck::runMetacheck()

NAMESPACE

@@ -2,6 +2,7 @@
 
 export("%>%")
 export(accumulate_pred_trans)
+export(add_attachment_mc)
 export(assert_metacheckable)
 export(auth_cr)
 export(auth_mailjet)
@@ -11,11 +12,14 @@ export(cr_compliance_overview)
 export(cr_funder_df)
 export(cr_has_orcid)
 export(cr_tdm_df)
+export(create_and_attach_ss)
+export(create_ss)
 export(doi_examples)
 export(draft_report)
 export(emailReport)
 export(emailReportServer)
 export(emailReportUI)
+export(email_async)
 export(funder_metrics)
 export(get_cr_md)
 export(get_delayed_license)
@@ -37,18 +41,16 @@ export(mc_long_docs)
 export(mc_long_docs_string)
 export(mc_render_email)
 export(mc_translator)
-export(md_data_attachment)
 export(metrics_overview)
 export(pretests)
-export(render_and_send)
-export(render_and_send_async)
 export(render_report)
 export(report_metacheckable)
 export(runMetacheck)
 export(smtp_send_mc)
 export(tabulate_metacheckable)
 export(tdm_metrics)
 export(vor_issue)
+export(write_xlsx_mc)
 import(dplyr)
 import(purrr)
 import(tidyr)

R/aaa.R

@@ -57,7 +57,10 @@ auth_mailjet <- function() {
       username = mailjet_username
     ),
     error = function(x) {
-      warning("Could not find Mailjet SMTPs credentials; you may not be send out email.")
+      warning(
+        "Could not find Mailjet SMTPs credentials;
+        you may not be able to send out email."
+      )
       return(character(1))
     }
   )

R/communicate.R

@@ -8,7 +8,6 @@ runMetacheck <- function(...) shiny::runApp(appDir = mcApp(), ...)
 #' @family communicate
 #' @export
 mcApp <- function() {
-  future::plan(future::multicore, workers = 20L)
   shiny::shinyApp(
     ui = mcAppUI(),
     server = mcAppServer

R/email.R

@@ -5,16 +5,14 @@ NULL
 
 #' @describeIn email Compose complete mail
 #' @inheritDotParams mc_render_email
+#' @inheritParams biblids::doiEntryUI
 #' @export
-mc_compose_email <- function(dois,
+mc_compose_email <- function(dois = doi_examples$good[1:10],
                              translator = mc_translator(),
                              ...) {
   mc_body_block(dois = dois, translator = translator, ...) %>%
     mc_compose_email_outer(translator = translator) %>%
-    blastula::add_attachment(
-      md_data_attachment(dois = dois),
-      filename = translator$translate("mc_individual_results.xlsx")
-    )
+    create_and_attach_ss(email = ., dois = dois, translator = translator)
 }
 
 mc_body_block <- function(dois, translator = mc_translator(), ...) {
@@ -136,56 +134,21 @@ block_text_centered_vec <- function(...) {
 
 #' @describeIn email Render email body (inner content)
 #' @inheritParams report
+#' @inheritParams blastula::render_email
 #' @inheritDotParams blastula::render_email
 #' @export
 mc_render_email <- function(dois = doi_examples$good[1:10],
                             translator = mc_translator(),
+                            quiet = !interactive(),
                             ...) {
-  # suppression is dangerous hack-fix for
-  # https://github.com/subugoe/metacheck/issues/138
-  # otherwise, tests are illegibly noisy
-  suppressWarnings(
-    blastula::render_email(
-      input = path_report_rmd(lang = translator$get_translation_language()),
-      render_options = list(
-        params = list(
-          dois = dois,
-          translator = translator
-        )
-      ),
-      ...
-    )
-  )
-}
-
-#' @describeIn email Render and send
-#' @inheritDotParams mc_compose_email
-#' @inheritParams smtp_send_mc
-#' @export
-render_and_send <- function(to, translator = mc_translator(), ...) {
-  email <- mc_compose_email(
-    translator = translator,
+  blastula::render_email(
+    input = path_report_rmd(lang = translator$get_translation_language()),
+    render_options = list(
+      params = list(dois = dois)
+    ),
+    quiet = quiet,
     ...
   )
-  smtp_send_mc(to = to, email = email, translator = translator)
-}
-
-#' @describeIn email Render and send asynchronously
-#' @export
-render_and_send_async <- function(...) {
-  # this is a workaround to enable async when developing on macOS
-  # macOS forked processes apparently cannot read keychain (makes sense)
-  # so we have to pass in the password manually
-  auth_mailjet()
-  mj_pw <- Sys.getenv("MAILJET_SMTP_PASSWORD")
-  promises::future_promise(
-    expr = {
-      Sys.setenv("MAILJET_SMTP_PASSWORD" = mj_pw)
-      render_and_send(...)
-    },
-    seed = TRUE
-  )
-  NULL
 }
 
 # sending ====
@@ -211,7 +174,7 @@ smtp_send_mc <- function(email = blastula::prepare_test_message(),
     credentials = credentials,
     ...
   )
-  invisible(email) # best practice
+  invisible(email) # best practice for funs called for side effects
 }
 
 #' Get credentials for smtp
@@ -361,68 +324,107 @@ emailReportServer <- function(id,
       })
       shiny::observeEvent(input$send, {
         if (iv$is_valid()) {
-          shiny::showModal(modalDialog(
-            title = translWithLang()$translate(
-              "You have successfully sent your DOIs"
-            ),
-            glue::glue(
-              translWithLang()$translate(
-                "You will receive an email with your report within the next 45 minutes. "
-              ),
-              translWithLang()$translate(
-                "Please check your SPAM folder. "
-              )
-            ),
-            easyClose = TRUE,
-            footer = NULL
-          ))
-          render_and_send_async(
+          toggle_email_input_elements()
+          promise_list <- email_async(
             to = input$recipient,
             dois = dois(),
             translator = translWithLang()
           )
+          promises::then(
+            promise_list$done,
+            onFulfilled = function(value) toggle_email_input_elements()
+          )
         }
       })
     }
   )
 }
 
-# excel attachment ====
+#' @describeIn emailReport Dis/enable all input elements in the module
+toggle_email_input_elements <- function() {
+  shinyjs::toggleState("recipient")
+  shinyjs::toggleState("gdpr_consent")
+  shinyjs::toggleState("send")
+}
 
-#' Make Spreadsheet attachment
-#' Creates an excel spreadsheet with individual-level results.
-#' 
-#' @details `r metacheck::mc_long_docs_string("spreadsheet.md")`
-#' 
-#' @param dois character, *all* submitted dois
-#' @param df compliance data from [cr_compliance_overview()]
-#' @inheritParams writexl::write_xlsx
-#' 
-#' @return path to the created file
-#'
+#' @describeIn emailReport Promise of a rendered and send email
+#' Emits notifications and progress bar updates.
+#' @inheritParams mc_compose_email
+#' @inheritDotParams mc_compose_email
+#' @inheritParams smtp_send_mc
 #' @export
-#' @family communicate
-md_data_attachment <- function(dois,
-                               df = cr_compliance_overview(get_cr_md(
-                                 dois[is_metacheckable(dois)]
-                              )),
-                              path = fs::file_temp(ext = "xlsx")) {
-  is_compliance_overview_list(df)
-  df[["pretest"]] <- tibble::tibble(
-    # writexl does not know vctrs records
-    doi = as.character(biblids::as_doi(dois)),
-    tabulate_metacheckable(dois)
+email_async <- function(to, translator = mc_translator(), ...) {
+  shiny::showNotification(
+    ui = glue::glue(
+      translator$translate("Your email report is being prepared."),
+      translator$translate(
+        "You can close this window or wait for completion. "
+      ),
+      translator$translate("Remember to check your SPAM folder.")
+    ),
+    duration = NULL,
+    id = "notifi_start",
+    type = "message"
   )
-  writexl::write_xlsx(
-    x = df,
-    path = path
+  pb <- shiny::Progress$new()
+  pb$set(value = 0, message = translator$translate("Starting ..."))
+  # this is strictly out of order and is only needed later
+  # but run here, b/c it actually need not be async,
+  # so placing this here is cleaner to read
+  pb$set(
+    value = 1/4,
+    message = translator$translate("Authenticating email relay ...")
   )
-}
-
-#' Data is available
-#' @noRd
-is_compliance_overview_list <- function(x) {
-  assertthat::assert_that(x %has_name% c("cr_overview", "cc_license_check"),
-                          msg = "No Compliance Data to attach, compliance data from [cr_compliance_overview()]"
+  # this is a workaround to enable async when developing on macOS
+  # macOS forked processes apparently cannot read keychain (makes sense)
+  # so we have to pass in the password manually
+  auth_mailjet()
+  mj_pw <- Sys.getenv("MAILJET_SMTP_PASSWORD")
+  promise_email <- promises::future_promise(
+    expr = mc_compose_email(translator = translator, ...),
+    seed = TRUE
+  )
+  pb$set(
+    value = 2/4,
+    message = translator$translate("Composing email ..."),
+    detail = translator$translate("This can take several minutes.")
+  )
+  promise_sent <- promises::then(
+    promise_email,
+    onFulfilled = function(value) {
+      pb$set(
+        value = 3/4,
+        message = translator$translate("Sending email ...")
+      )
+      promises::future_promise(
+        expr = {
+          Sys.setenv("MAILJET_SMTP_PASSWORD" = mj_pw)
+          smtp_send_mc(to = to, email = value, translator = translator)
+        },
+        seed = TRUE
+      )
+    }
+  )
+  id_notifi_done <- "notifi_done"
+  promise_done <- promises::then(
+    promise_sent,
+    onFulfilled = function(value) {
+      pb$set(value = 4/4, message = translator$translate("Done."))
+      pb$close()
+      shiny::removeNotification("notifi_start")
+      shiny::showNotification(
+        ui = glue::glue(
+          translator$translate("Your report is in your email inbox. "),
+          translator$translate("Remember to check your SPAM folder. ")
+        ),
+        duration = NULL,
+        closeButton = TRUE,
+        id = id_notifi_done,
+        type = "message"
+      )
+      value
+    }
   )
+  # both are needed upstream
+  list(done = promise_done, id_notifi = id_notifi_done)
 }

R/import.R

@@ -58,10 +58,14 @@ looped_possibly_cr_works_field <- function(x, field, ...) {
   x <- biblids::as_doi(x)
   # remove this hackfix https://github.com/subugoe/metacheck/issues/182
   x <- as.character(x)
+  pb <- progressr::progressor(
+    along = x,
+    message = "Querying Crossref API (works endpoint) ...",
+    label = "memoised_possibly_cr_works_field"
+  )
   res <- purrr::map_chr(
     x,
-    memoised_possibly_cr_works_field,
-    field = field,
+    function(x) {pb(); memoised_possibly_cr_works_field(x, field = field, ...)},
     ...
   )
   res

R/metrics_funder.R

@@ -30,8 +30,9 @@ funder_metrics <- function(funder_info = NULL) {
     mutate(name = ifelse(is.na(.data$name), "No funding info", .data$name)) %>%
     mutate(name = forcats::fct_lump_prop(.data$name, prop = 0.03, other_level = "Other funders")) %>%
     mutate(name = forcats::fct_infreq(.data$name)) %>%
-    mutate(name = forcats::fct_relevel(.data$name, "Other funders", after = Inf)) %>%
-    mutate(name = forcats::fct_relevel(.data$name, "No funding info", after = Inf))
+    # TODO hack fix to avoid spurious warnings https://github.com/subugoe/metacheck/issues/344
+    suppressWarnings(mutate(name = forcats::fct_relevel(.data$name, "Other funders", after = Inf))) %>%
+    suppressWarnings(mutate(name = forcats::fct_relevel(.data$name, "No funding info", after = Inf)))
   } else {
     out <-funder_info %>%
       mutate(name = ifelse(is.na(.data$name), "No funding info", .data$name)) %>%