Add function for fetching in progress responses, closing #220

NAMESPACE

@@ -8,6 +8,7 @@ export(fetch_description)
 export(fetch_distribution_history)
 export(fetch_distributions)
 export(fetch_id)
+export(fetch_inprogress)
 export(fetch_mailinglist)
 export(fetch_survey)
 export(generate_url)

R/fetch_inprogress.R

@@ -0,0 +1,169 @@
+#' Download in progress responses from a survey and import it into R
+#'
+#' Download in progress responses from a Qualtrics survey you own via API and import the survey directly into R.
+#'
+#' @inheritParams fetch_survey
+#'
+#' @seealso See <https://api.qualtrics.com/> for documentation on
+#' the Qualtrics API.
+#' @template retry-advice
+#' @importFrom lifecycle deprecated
+#' @export
+#' @examples
+#' \dontrun{
+#' # Register your Qualtrics credentials if you haven't already
+#' qualtrics_api_credentials(
+#'   api_key = "<YOUR-API-KEY>",
+#'   base_url = "<YOUR-BASE-URL>"
+#' )
+#'
+#' # Retrieve a list of surveys
+#' surveys <- all_surveys()
+#'
+#' # Retrieve a single survey
+#' mysurvey <- fetch_inprogress(surveyID = surveys$id[6])
+#'
+#' mysurvey <- fetch_inprogress(
+#'   surveyID = surveys$id[6],
+#'   save_dir = tempdir(),
+#'   start_date = "2018-01-01",
+#'   end_date = "2018-01-31",
+#'   limit = 100,
+#'   label = TRUE,
+#'   unanswer_recode = 999,
+#'   verbose = TRUE,
+#'   # Manually override EndDate to be a character vector
+#'   col_types = readr::cols(EndDate = readr::col_character())
+#' )
+#'
+#' }
+#'
+fetch_inprogress <- function(surveyID,
+                         last_response = deprecated(),
+                         start_date = NULL,
+                         end_date = NULL,
+                         unanswer_recode = NULL,
+                         unanswer_recode_multi = unanswer_recode,
+                         include_display_order = TRUE,
+                         limit = NULL,
+                         include_questions = NULL,
+                         save_dir = NULL,
+                         force_request = FALSE,
+                         verbose = TRUE,
+                         label = TRUE,
+                         convert = TRUE,
+                         import_id = FALSE,
+                         time_zone = NULL,
+                         breakout_sets = TRUE,
+                         add_column_map = TRUE,
+                         add_var_labels = TRUE,
+                         col_types = NULL) {
+
+  if (lifecycle::is_present(last_response)) {
+    lifecycle::deprecate_warn("3.1.2", "fetch_inprogress(last_response = )")
+  }
+
+  ## Are the API credentials stored?
+  assert_base_url()
+  assert_api_key()
+
+  check_params(
+    verbose = verbose,
+    convert = convert,
+    import_id = import_id,
+    time_zone = time_zone,
+    label = label,
+    start_date = start_date,
+    end_date = end_date,
+    include_questions = include_questions,
+    save_dir = save_dir,
+    unanswer_recode = unanswer_recode,
+    unanswer_recode_multi = unanswer_recode_multi,
+    include_display_order = include_display_order,
+    limit = limit,
+    breakout_sets = breakout_sets,
+    add_column_map = add_column_map,
+    add_var_labels = add_var_labels
+  )
+
+  # See if survey already in tempdir
+  if (!force_request) {
+    if (paste0(surveyID, "_inprogress.rds") %in% list.files(tempdir())) {
+      data <- readRDS(paste0(tempdir(), "/", surveyID, "_inprogress.rds"))
+      if (verbose) {
+        rlang::inform(paste0(
+          "Found an earlier download for survey with id ", surveyID, # nolint
+          ". Loading this file.\nSet 'force_request' to TRUE if you want to override this."
+        ))
+      } # nolint
+      return(data)
+    }
+  }
+
+  # CONSTRUCT API CALL ----
+
+  # fetch URL:
+  fetch_url <- generate_url(query = "fetchsurvey",
+                            surveyID = surveyID)
+
+  # Create raw JSON payload
+  raw_payload <- create_raw_payload(
+    label = label,
+    start_date = start_date,
+    end_date = end_date,
+    unanswer_recode = unanswer_recode,
+    unanswer_recode_multi = unanswer_recode_multi,
+    include_display_order = include_display_order,
+    limit = limit,
+    time_zone = time_zone,
+    include_questions = include_questions,
+    breakout_sets = breakout_sets,
+    responses_in_progress = TRUE
+  )
+
+  # SEND POST REQUEST TO API ----
+
+  # POST request for download
+  res <- qualtrics_api_request("POST", url = fetch_url, body = raw_payload)
+  # Get id
+  if (is.null(res$result$progressId)) {
+      stop("Something went wrong. Please re-run your query.")
+    } else {
+    requestID <- res$result$progressId
+  } # NOTE This is not fail safe because ID can still be NULL
+
+  # Download, unzip and return file path
+  survey.fpath <- download_qualtrics_export(fetch_url, requestID, verbose = verbose)
+
+  # READ DATA AND SET VARIABLES ----
+
+  # Read data
+
+  data <- read_survey(survey.fpath, import_id = import_id,
+                      time_zone = time_zone,
+                      col_types = col_types,
+                      add_column_map = add_column_map)
+
+  # Add types
+  if (convert & label) {
+    data <- infer_data_types(data, surveyID)
+  }
+
+  # Save survey as RDS file in temp folder so that it can be easily
+  # retrieved this session.
+  saveRDS(data, paste0(tempdir(), "/", surveyID, "_inprogress.rds"))
+
+  # RETURN ----
+
+  # Remove tmpfiles
+  if (!is.null(save_dir)) {
+    # Save file to directory
+    saveRDS(data, file = paste0(save_dir, "/", surveyID, "_inprogress.rds"))
+    # Return
+    return(data)
+  } else {
+    p <- file.remove(survey.fpath)
+    # Return
+    return(data)
+  }
+}

R/utils.R

@@ -272,7 +272,8 @@ create_raw_payload <- function(label = TRUE,
                                unanswer_recode_multi = NULL,
                                include_display_order = TRUE,
                                include_questions = NULL,
-                               breakout_sets = NULL) {
+                               breakout_sets = NULL,
+                               responses_in_progress = NULL) {
 
   params <- as.list(environment())
 
@@ -286,7 +287,8 @@ create_raw_payload <- function(label = TRUE,
       unanswer_recode_multi = "multiselectSeenUnansweredRecode",
       include_display_order = "includeDisplayOrder",
       include_questions = "questionIds",
-      breakout_sets = "breakoutSets")
+      breakout_sets = "breakoutSets",
+      responses_in_progress = "exportResponsesInProgress")