R/splitForms.R

In redcapAPI: Interface to 'REDCap'

#' @name splitForms
#' @title Split a Data Frame into its Forms
#' 
#' @description Separates a data frame from REDCap into a list of data 
#'   frames where each form constitutes an element in the list. 
#'   
#' @inheritParams common-rcon-arg
#' @param Records `data.frame` such as one generated by `exportRecords` or 
#'   `exportRecordsTyped`
#' @param envir environment. The target environment for the resulting list
#'   of `data.frame`s. Defaults to `NULL` which returns the a list. 
#'   Use `globalenv` to assign the global environment. Will accept a number
#'   of the environment.
#' @param base `character(1)` giving the start of the naming scheme 
#'   for the elements of the list. By default, the names of the list will
#'   be the form names. If this value is provided, it will follow the 
#'   format `base.form_name`.
#' @param post `function` to apply to each element of form data 
#'   after separating them, must be of signature `function(data, rcon)`.
#'   
#' @seealso
#' ## Other post-processing functions
#' 
#' [recastRecords()], \cr
#' [guessCast()], \cr
#' [guessDate()], \cr
#' [castForImport()], \cr
#' [mChoiceCast()], \cr
#' [widerRepeated()]
#' 
#' @examples
#' \dontrun{
#' unlockREDCap(connections = c(rcon = "project_alias"), 
#'              url = "your_redcap_url", 
#'              keyring = "API_KEYs", 
#'              envir = globalenv())
#'              
#' Records <- exportRecordsTyped(rcon)
#' 
#' splitForms(Records, rcon)
#' }
#'    
#'   
#' @export

splitForms <- function(Records, 
                       rcon, 
                       envir = NULL, 
                       base  = NULL, 
                       post  = NULL){
  ###################################################################
  # Argument Validation                                          ####
  if(is.numeric(envir)) envir <- as.environment(envir)
  
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert_data_frame(x = Records, 
                               add = coll)
  
  checkmate::assert_class(x = rcon, 
                          classes = "redcapConnection", 
                          add = coll)
  
  checkmate::assert_environment(x = envir, 
                                null.ok = TRUE, 
                                add = coll)
  
  checkmate::assert_character(x = base, 
                              len = 1, 
                              null.ok = TRUE, 
                              any.missing = FALSE,
                              add = coll)
  
  checkmate::assert_function(x = post, 
                             null.ok = TRUE, 
                             add = coll)
  
  checkmate::reportAssertions(coll)
  
  ###################################################################
  # Split Forms                                                  ####
  
  id_vars <- c(getProjectIdFields(rcon),
               REDCAP_SYSTEM_FIELDS)
  id_vars <- id_vars[id_vars %in% names(Records)]
  
  FieldNames <- rcon$fieldnames()
  FieldNames <- FieldNames[FieldNames$export_field_name %in% names(Records), , drop = FALSE]
  FieldNames <- FieldNames[!FieldNames$original_field_name %in% id_vars, , drop = FALSE]
  
  MetaData <- rcon$metadata()
  MetaData <- MetaData[MetaData$field_name %in% FieldNames$original_field_name, , drop = FALSE]
  
  FormNames <- split(MetaData$field_name, 
                     MetaData$form_name, 
                     drop = TRUE)
  
  form_order <- rcon$instruments()$instrument_name
  form_order <- form_order[form_order %in% names(FormNames)]
  
  FormNames <- FormNames[form_order]
  
  FormNames <- lapply(FormNames, 
                      function(fn){
                        FN <- rcon$fieldnames()
                        FN$export_field_name[FN$original_field_name %in% fn]
                      })
  
  FormNames <- lapply(FormNames, 
                      function(fn){
                        fn <- c(id_vars, fn)
                        fn[!duplicated(fn)]
                      })
  
  FormData <- lapply(FormNames, 
                     function(fn){
                       Records[fn]
                     })
  
  FormData <- lapply(FormData, 
                     filterEmptyRow, 
                     rcon = rcon)
  
  ###################################################################
  # Add the invalid attribute to each element                    ####
  
  FormData <- lapply(FormData, 
                     function(fd){
                       inv <- attr(Records, "invalid")
                       inv <- inv[inv$field_name %in% names(fd), , drop = FALSE]
                       if (!is.null(inv) && nrow(inv) > 0){
                         attr(fd, "invalid") <- inv
                       }
                       fd
                     })
  
  ###################################################################
  # Apply the base name, if necessary                            ####
  
  if (!is.null(base)){
    names(FormData) <- paste0(base, ".", names(FormData))
  }
  
  ###################################################################
  # Apply the function to the list                               ####
  if (!is.null(post)){
    FormData <- lapply(FormData, 
                       function(x) post(x, rcon))
  }
  
  ###################################################################
  # Return the Result                                            ####

  if(is.null(envir)) FormData else list2env(FormData, envir=envir)
}