Merge branch 'release/1.24.0'

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: redcapcustodian
 Type: Package
 Title: Data automation for R-centric workflows with a nod towards REDCap
-Version: 1.23.0
+Version: 1.24.0
 Authors@R: c(
   person("Philip", "Chase",
         email = "pbc@ufl.edu",
@@ -23,6 +23,10 @@ Authors@R: c(
         email = "mbentz@ufl.edu",
         role = "aut",
         comment=c(ORCID = "0000-0002-5790-4268")),
+  person("Sai Pavan", "Kamma",
+        email = "saipavankamma@ufl.edu",
+        role = "aut",
+        comment=c(ORCID = "0009-0004-4619-0409")),
   person("Christopher", "Barnes",
         email = "cpb@ufl.edu",
         role = "ctb",
@@ -70,6 +74,6 @@ Suggests:
     tidyverse
 VignetteBuilder: knitr
 Config/testthat/edition: 3
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Depends: 
     R (>= 3.5.0)

NAMESPACE

@@ -20,6 +20,7 @@ export(export_allocation_tables_from_project)
 export(get_bad_emails_from_individual_emails)
 export(get_bad_emails_from_listserv_digest)
 export(get_current_time)
+export(get_hipaa_disclosure_log_from_ehr_fhir_logs)
 export(get_institutional_person_data)
 export(get_job_duration)
 export(get_package_scope_var)

NEWS.md

@@ -1,3 +1,11 @@
+# redcapcustodian 1.24.0 (released 2024-10-17)
+- Add job failure alerts with run_etl.R and updates to send_mail() (@ljwoodley, #100, #165)
+- Add Sai as author in DESCRIPTION (@pbchase)
+- Filter out deleted projects in scrape_user_api_tokens() (@pbchase, #163, #164)
+- Move Roxygen2 to 7.3.2 (@pbchase)
+- Add get_hipaa_disclosure_log_from_ehr_fhir_logs() (@pbchase, #158)
+- Update run-tests.yaml to use rstudio-ci:4.3.3 (@pbchase)
+
 # redcapcustodian 1.23.0 (released 2024-06-13)
 - Add project and instance to logging (@ljwoodley, @pbchase, #159, #160)
 

R/credential_management.R

@@ -41,11 +41,15 @@ scrape_user_api_tokens <- function(conn, username_to_scrape = Sys.info()[["user"
       dplyr::tbl(conn, "redcap_projects") %>%
         dplyr::select(
           "project_id",
-          "app_title"
+          "app_title",
+          "date_deleted"
         ),
       by = "project_id"
     ) %>%
     dplyr::collect() %>%
+    # filter out deleted projects
+    dplyr::filter(is.na(.data$date_deleted)) |>
+    dplyr::select(-"date_deleted") |>
     # bind_rows used over rbind to avoid need to align column order
     dplyr::bind_rows(super_credentials) %>%
     dplyr::rename(
@@ -125,12 +129,9 @@ set_project_api_token <- function(conn, username, project_id) {
   DBI::dbExecute(conn, sql)
 }
 
-
-
 save_credentials <- function(
-                             file_path,
-                             project_id = "0",
-                             token
-                             ) {
+    file_path,
+    project_id = "0",
+    token) {
 
 }

R/get_hipaa_disclosure_log_from_ehr_fhir_logs.R

@@ -0,0 +1,77 @@
+#' get_hipaa_disclosure_log_from_ehr_fhir_logs
+#' @description
+#' Read a data needed for a HIPAA disclosure log from a REDCap database
+#' given a DBI connection object to the REDCap database and some optional
+#' parameters to narrow the returned result.
+#'
+#' @param conn a DBI connection object to the REDCap database
+#' @param ehr_id the REDCap EHR_ID for the EHR of interest (optional)
+#' @param start_date The first date from which we should return results (optional)
+#'
+#' @return A dataframe suitable for generating a HIPAA disclosure log
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' library(tidyverse)
+#' library(lubridate)
+#' library(REDCapR)
+#' library(dotenv)
+#' library(redcapcustodian)
+#' library(DBI)
+#' library(RMariaDB)
+#'
+#' init_etl("export_fhir_traffic_log")
+#' conn <- connect_to_redcap_db()
+#'
+#' get_hipaa_disclosure_log_from_ehr_fhir_logs(conn)
+#' }
+get_hipaa_disclosure_log_from_ehr_fhir_logs <- function(
+    conn,
+    ehr_id = NA_real_,
+    start_date = as.Date(NA)) {
+  # make DBI objects for joins
+  user_information <- dplyr::tbl(conn, "redcap_user_information") |>
+    dplyr::select(
+      "ui_id",
+      "username"
+    )
+
+  projects <- dplyr::tbl(conn, "redcap_projects") |>
+    dplyr::select(
+      "project_id",
+      "app_title",
+      "project_pi_firstname",
+      "project_pi_mi",
+      "project_pi_lastname",
+      "project_pi_email",
+      "project_pi_alias",
+      "project_irb_number"
+    )
+
+  disclosures <- dplyr::tbl(conn, "redcap_ehr_fhir_logs") |>
+    dplyr::filter(.data$resource_type == "Patient" & .data$mrn != "") |>
+    dplyr::left_join(user_information, by = c("user_id" = "ui_id")) |>
+    dplyr::left_join(projects, by = c("project_id")) |>
+    dplyr::collect() |>
+    dplyr::mutate(disclosure_date = lubridate::floor_date(.data$created_at, unit = "day")) |>
+    dplyr::select(-c("id", "created_at")) |>
+    dplyr::distinct() |>
+    dplyr::arrange(.data$disclosure_date) |>
+    dplyr::rename(redcap_project_name = "app_title") |>
+    dplyr::select(
+      "disclosure_date",
+      "fhir_id",
+      "mrn",
+      "project_irb_number",
+      "project_pi_firstname",
+      "project_pi_mi",
+      "project_pi_lastname",
+      "project_pi_email",
+      "redcap_project_name",
+      "username",
+      dplyr::everything()
+    )
+
+  return(disclosures)
+}

R/logging.R

@@ -641,7 +641,7 @@ write_info_log_entry <- function(conn, target_db_name, table_written = NULL, df,
 #' @param email_from The email addresses of the sender
 #' @param df_to_email (Optional) A dataframe or a list of dataframes to be included as file attachment(s). If this parameter is used, `file_name` must also be specified.
 #'                    Each dataframe in the list must have a corresponding file name in the `file_name` parameter to ensure a one-to-one match between dataframes and file names.
-#' @param file_name (Optional) A character vector specifying the file name(s) of the attachment(s). Valid file extensions are `.csv`, `.xlsx`, and `.zip`. Each file name must be unique.
+#' @param file_name (Optional) A character vector specifying the file name(s) of the attachment(s). Valid file extensions are `.csv`, `.xlsx`, `.zip` and, `.txt`. Each file name must be unique.
 #' @param ... Additional arguments passed directly to the file writing functions: `write.csv` for CSV files, and `writexl::write_xlsx` for XLSX files.
 #'
 #' @return No returned value. It performs an action by sending an email.
@@ -783,7 +783,7 @@ send_email <-
           }
         }
 
-        if (file_extension == "zip" &&
+        if ((file_extension == "zip" || file_extension == "txt") &&
             !file.copy(file_name[[i]], output_dir, overwrite = TRUE)) {
           stop(paste("Failed to move", file_name[[i]]))
         }

R/read_email.R

@@ -10,7 +10,7 @@
 #'
 #' @return A dataframe of bounced email addresses
 #' \itemize{
-#'   \item{\code{email}}{character email address the bounced}
+#'   \item email character email address the bounced
 #' }
 #' @export
 #' @importFrom magrittr "%>%"

VERSION

@@ -1 +1 @@
-1.23.0
+1.24.0

etl/run_etl.R

@@ -0,0 +1,47 @@
+library(redcapcustodian)
+library(dotenv)
+library(callr)
+library(argparse)
+
+set_script_run_time()
+
+parser <- ArgumentParser()
+parser$add_argument("script_name", help="Script to be run")
+parser$add_argument("optional_args", nargs='*', help="Zero or more optional arguments of any type")
+
+if (!interactive()) {
+  args <- parser$parse_args()
+} else {
+  args <- parser$parse_args(
+    c(
+      "study_template/etl/test_failure_alert.R",
+      "test",
+      "another test"
+    )
+  )
+}
+
+script_name <- args$script_name
+optional_args <- args$optional_args
+
+if(!fs::file_exists(script_name)) {
+  stop(sprintf("Specified file, %s, does not exist", script_name))
+}
+
+tryCatch({
+  if (length(optional_args) == 0) {
+    rscript(script = script_name, stderr = "log.txt")
+  } else {
+    rscript(script = script_name, cmdargs = optional_args, stderr = "log.txt")
+  }
+}, error = function(e) {
+  email_body <- "See the attached log for error details."
+  script_path <- paste(basename(getwd()), script_name, sep = "/")
+  email_subject <- paste0("Failed | ", script_path, " | ", format(get_script_run_time(), "%Y-%m-%d"))
+  file_name = "log.txt"
+
+  send_email(email_body = email_body, email_subject = email_subject, file_name = file_name)
+})
+
+
+

etl/test_failure_alert.R

@@ -0,0 +1,11 @@
+print("Hello, example host!")
+
+args <- commandArgs(trailingOnly = TRUE)
+
+# Test that the command line args are read
+print(paste0("This is a ", args[1]))
+print(paste0("This is ", args[2]))
+
+# This will fail as test.csv does not exist.
+read.csv("test.csv")
+

study_template/cron/test_failure_alert

@@ -0,0 +1,3 @@
+# Test email alert on script failure
+0 0 1 * * root /usr/bin/docker run --rm --env-file /rcc/study_template/.env rcc.site Rscript etl/run_etl.R etl/test_failure_alert.R test "another test"
+

study_template/etl/run_etl.R

@@ -0,0 +1,47 @@
+library(redcapcustodian)
+library(dotenv)
+library(callr)
+library(argparse)
+
+set_script_run_time()
+
+parser <- ArgumentParser()
+parser$add_argument("script_name", help="Script to be run")
+parser$add_argument("optional_args", nargs='*', help="Zero or more optional arguments of any type")
+
+if (!interactive()) {
+  args <- parser$parse_args()
+} else {
+  args <- parser$parse_args(
+      c(
+        "study_template/etl/test_failure_alert.R",
+        "test",
+        "another test"
+      )
+    )
+}
+
+script_name <- args$script_name
+optional_args <- args$optional_args
+
+if(!fs::file_exists(script_name)) {
+  stop(sprintf("Specified file, %s, does not exist", script_name))
+}
+
+tryCatch({
+  if (length(optional_args) == 0) {
+    rscript(script = script_name, stderr = "log.txt")
+  } else {
+    rscript(script = script_name, cmdargs = optional_args, stderr = "log.txt")
+  }
+}, error = function(e) {
+  email_body <- "See the attached log for error details."
+  script_path <- paste(basename(getwd()), script_name, sep = "/")
+  email_subject <- paste0("Failed | ", script_path, " | ", format(get_script_run_time(), "%Y-%m-%d"))
+  file_name = "log.txt"
+
+  send_email(email_body = email_body, email_subject = email_subject, file_name = file_name)
+})
+
+
+

study_template/etl/test_failure_alert.R

@@ -0,0 +1,11 @@
+print("Hello, example host!")
+
+args <- commandArgs(trailingOnly = TRUE)
+
+# Test that the command line args are read
+print(paste0("This is a ", args[1]))
+print(paste0("This is ", args[2]))
+
+# This will fail as test.csv does not exist.
+read.csv("test.csv")
+

tests/testthat/helper.R

@@ -32,3 +32,8 @@ if (is.null(salt)) {
   set_package_scope_var("salt", paste0(runif(1), runif(1), runif(1)))
   salt <- get_package_scope_var("salt")
 }
+
+# write a dataframe, referenced by 'table_name' to tests/testthat/directory_under_test_path
+write_rds_to_test_dir <- function(table_name, directory_under_test_path) {
+  get(table_name) |> saveRDS(testthat::test_path(directory_under_test_path, paste0(table_name, ".rds")))
+}