Merge pull request #44 from gongcastro/test

Add track_progress function

NAMESPACE

@@ -18,6 +18,7 @@ export(get_bvq_runs)
 export(get_doe)
 export(get_longitudinal)
 export(prop_adj)
+export(track_progress)
 import(dplyr)
 import(rlang)
 importFrom(cli,cli_abort)

R/import.R

@@ -62,6 +62,7 @@ collect_survey <- function(version,
 #' @importFrom formr formr_raw_results
 #'
 #' @param surveys Name of the surveys in the formr run.
+#' @param verbose Should progress messages be printed in the console?
 #' @param ... Unused.
 #' 
 #' @author Gonzalo Garcia-Castro
@@ -70,22 +71,22 @@ collect_survey <- function(version,
 #' @keywords internal
 #' 
 #' @md
-download_surveys <- function(surveys, ...) {
+download_surveys <- function(surveys, verbose = TRUE, ...) {
     n <- length(surveys)
     i <- 0
     raw <- vector(mode = "list", length = n)
 
-    if (interactive()) {
+    if (verbose && interactive()) {
         step_msg <- "Downloaded {i}/{n} {qty(i)}survey{?s}"
         cli_progress_step(msg = step_msg)
     }
 
     for (i in seq_along(surveys)) {
         raw[[i]] <- formr::formr_raw_results(surveys[i])
-        if (interactive()) cli_progress_update()
+        if (verbose && interactive()) cli_progress_update()
     }
 
-    if (interactive()) cli_progress_done(result = "done")
+    if (verbose && interactive()) cli_progress_done(result = "done")
 
     raw <- lapply(raw, select, -any_of("language"))
     names(raw) <- surveys

R/logs.R

@@ -132,7 +132,7 @@ bvq_logs <- function(participants = bvq_participants(),
             age = diff_in_time(date_finished, date_birth, "months"),
             duration = diff_in_time(date_finished, date_started, "days")
         ) %>%
-        # compute participant's progres through the questionnaire
+        # compute participant's progress through the questionnaire
         mutate(progress = complete_items / total_items,
                completed = progress >= 0.95) %>%
         # select relevant columns and reorder them
@@ -141,3 +141,63 @@ bvq_logs <- function(participants = bvq_participants(),
 
     return(logs)
 }
+
+#' Track a participant's response progress.
+#'
+#' This function prints some informative messages about a participants progress through the BVQ, and returns a vector of logical values indicating the surveys that the participant has completed.
+#'
+#' @importFrom lubridate as_datetime
+#'
+#' @export track_progress
+#'
+#' @param respose_id a character string identifying a single response to the questionnaire. This value is always unique for each response to the questionnaire, even for responses from the same participant.
+#' @param participants Participants data frame, as generated by
+#'   [bvq::bvq_participants()].
+#' @param ... Arguments passed to [bvq::download_surveys].
+#' @returns A logical vector indicating the surveys that the participant has completed.
+#' 
+#' @author Gonzalo Garcia-Castro
+#'
+#' @examples
+#' \dontrun{
+#' track_progress("1911", participants, verbose=FALSE)
+#' }
+#'
+#' @md
+track_progress <- function(response_id,
+                           participants = NULL,
+                           ...) {
+
+    if (is.null(participants)) participants <- bvq_participants()
+
+    version <- participants[participants$response_id==response_id,]$version
+    cli::cli_progress_step("Downloading responses from version {.val {version}}")
+    sur <- download_surveys(get_bvq_runs()[[version]], ...)
+
+    cli::cli_progress_step("Looking up status of response {.val {response_id}}")
+
+    logs <- sur[[1]]
+    logs$bl_code <- gsub("BL", "", logs$bl_code)
+    logs <- fix_code_raw(logs) 
+    logs <- logs[logs$bl_code %in% response_id, ]
+    formr_id <- logs$session
+
+    status <- vapply(lapply(sur, `[[`, "session"),  
+                     \(x) formr_id %in% x, logical(1))
+    finished <- all(status)
+    status_label <- ifelse(finished, "finished", "in progress")
+    sur_now <- sur[[last(which(status))]]
+    sur_now_nm <- names(sur[last(which(status))])
+    sur_now_created <- as_datetime(sur_now[sur_now$session %in% formr_id, ]$created)
+    sur_now_modified <- as_datetime(sur_now[sur_now$session %in% formr_id, ]$modified)
+    if (is.na(sur_now_modified)) sur_now_modified <- sur_now_created
+
+    cli::cli_progress_done(result = "done")
+
+    cli::cli_text("Response {.field {response_id}} is {.field {status_label}}")
+    cli::cli_li("In {.field {sur_now_nm}} since {.val {sur_now_created}}")
+    cli::cli_li("Logged in: {.val {as_datetime(logs$created)}}")
+    cli::cli_li("Last activity: {.val {as_datetime(logs$created)}}")
+
+    return(invisible(status))
+}

R/utils.R

@@ -297,6 +297,15 @@ get_bvq_runs <- function() { # nocov start
             "bvq_06_words_catalan",
             "bvq_06_words_spanish"
         ),
+        "bvq-1.0.1" = c(
+            "bvq_01_log",
+            "bvq_02_welcome",
+            "bvq_03_consent",
+            "bvq_04_demo",
+            "bvq_05_language",
+            "bvq_06_words_catalan",
+            "bvq_06_words_spanish"
+        ),
         "bvq-lockdown" = c(
             "bilexicon_lockdown_01_log",
             "bilexicon_lockdown_02_welcome",
@@ -331,7 +340,8 @@ get_bvq_runs <- function() { # nocov start
                                 "bvq-long" = "BL-Long",
                                 "bvq-short" = "BL-Short",
                                 "bvq-lockdown" = "BL-Lockdown",
-                                "bvq-1.0.0" = "1.0.0")
+                                "bvq-1.0.0" = "1.0.0",
+                                "bvq-1.0.1" = "1.0.1")
     return(runs)
 } # nocov end
 

_pkgdown.yml

@@ -56,6 +56,7 @@ reference:
 - title: "Helper functions"
   desc: "Additional functions to access and process the data"
   contents:
+  - track_progress
   - get_longitudinal
   - prop_adj
   - launch_app