R/redcapConnection.R

Defines functions .offlineConnection_readMetaData .fieldNamesFromMetaData .offlineConnection_readFile print.redcapOfflineConnection offlineConnection print.redcapApiConnection redcapConnection

Documented in offlineConnection print.redcapApiConnection print.redcapOfflineConnection redcapConnection

#' @name redcapConnection
#' @title Connect to a REDCap Database
#' 
#' @description These methods enable the user to create a connection object
#'   used to access the database. 
#' 
#' @param url `character(1)`. URL for the user's REDCap database API.  
#' @param token `character(1)` REDCap API token
#' @param config A list to be passed to [httr::POST()].  This allows the 
#'   user to set additional configurations for the API calls, such as 
#'   certificates, SSL version, etc. For the majority of users, this does 
#'   not need to be altered.
#' @param retries `integerish(1)`. Sets the number of attempts to make to the
#'   API if a timeout error is encountered. Must be a positive value.
#' @param retry_interval `numeric`. Sets the intervals (in seconds) at 
#'   which retries are attempted. By default, set at a `2^r` where 
#'   `r` is the `r`th retry (ie, 2, 4, 8, 16, ...). For fixed 
#'   intervals, provide a single value. Values will be recycled to match
#'   the number of retries.
#' @param retry_quietly `logical(1)`. When `FALSE`, messages will 
#'   be shown giving the status of the API calls. Defaults to `TRUE`.
#' @param x `redcapConnection` object to be printed
#' @param ... arguments to pass to other methods
#'   
#' @details
#' `redcapConnection` objects will retrieve and cache various forms of 
#' project information. This can make metadata, arms, events, etc. available 
#' directly from the `redcapConnection` object. The retrieval of these objects
#' uses the default values of the respective export functions (excepting the 
#' file repository, which uses `recursive = TRUE`). 
#' 
#' For each of these objects, there are four methods that can be called from 
#' the `redcapConnection` object: 
#' 
#' | Function type | Purpose | Example | 
#' |-----------------------|-------------------------------|----------------|
#' | `[info_type]`         | Returns the information from the connection object | `rcon$metadata()` |
#' | `has_[info_type]`     | Returns a boolean indicating if the information is cached | `rcon$has_metadata()` |
#' | `flush_[info_type]`   | Purges the information from the connection object | `rcon$flush_metadata()` | 
#' | `refresh_[info_type]` | Replaces the information with a new call to the API | `rcon$refresh_metadata()` |
#' 
#' Information is cached for 
#' 
#' * `metadata`
#' * `arms`
#' * `events`
#' * `instruments`
#' * `fieldnames`
#' * `mapping` (field-event mappings)
#' * `repeatInstrumentEvent`
#' * `users`
#' * `user_roles`
#' * `user_role_assignment`
#' * `dags`
#' * `dag_assignment`
#' * `projectInformation`
#' * `version`
#' * `fileRepository`
#' * `externalCoding`
#' 
#' There is also a `flush_all` and `refresh_all` method that will purge
#' the entire cache and refresh the entire cache, respectively.
#' 
#' The `externalCoding` elements relate to the code-label mappings of text fields 
#' with the external validation types (such as `sql` fields or text fields 
#' with BioPortal Ontology modules enabled). 
#' 
#' ## Specific to API Connections
#' 
#' The `redcapApiConnection` object also stores the user preferences for 
#' handling repeated attempts to call the API. In the event of a timeout 
#' error or server unavailability, these settings allow a system pause before
#' attempting another API call. In the event all of the retries fail, the 
#' error message of the last attempt will be returned. These settings may 
#' be altered at any time using the methods `rcon$set_retries(r)`, 
#' `rcon$set_retry_interval(ri)`, and `rcon$set_retry_quietly(rq)`. 
#' The argument to these functions have the same requirements as the 
#' corresponding arguments to `redcapConnection`.
#' 
#' Tokens are specific to a project, and a token must be created for each 
#' project for which the user wishes to use the API.
#' 
#' Additional Curl option can be set in the `config` argument.  See the documentation
#' for [httr::config()] and [httr::httr_options()] for more Curl options.
#' 
#' ## Specific to Offline Connections
#' 
#' "Offline connections" are a tool designed to provide the users without 
#' API privileges with at least a subset of the functionality available to 
#' API users. The offline connections are typically constructed from the 
#' comma separated value (CSV) files downloaded from the REDCap user 
#' interface. Alternatively, data frames may be provided with the 
#' necessary data.
#' 
#' Not all of the components of an offline connection are needed for most 
#' operations. Rather, the object was built to accept the same components
#' available to the `redcapApiConnection` in order to provide a consistent
#' interface and simplify future development.
#' 
#' The meta data will be required for nearly all operations. For 
#' validating and casting data, the `records` data must be provided, and 
#' works best if the data are the raw, unlabeled data downloaded from the
#' REDCap user interface.
#' 
#' Other components that may prove useful when casting records are the 
#' url, version, events (if the project is longitudinal), and a subset 
#' of the project information. The user is encouraged to review the 
#' vignette for working with offline connections for more details.
#' 
#' With offline connections, the refresh methods have an important difference.
#' The user may pass the refresh method a file path or data frame which 
#' will be used to replace the existing component. See examples. 
#' 
#' @seealso 
#' For establishing connections using secure token storage. \cr
#' [unlockREDCap()] \cr
#' `vignette("redcapAPI-getting-started-connecting", package = "redcapAPI")`\cr
#' 
#' For working with offline connections.
#' `vignette("redcapAPI-offline-connection", package = "redcapAPI")`\cr
#' \cr
#' To prepare data for an offline user, see [preserveProject()] and 
#' [readPreservedProject()].
#' 
#' 
#' @examples
#' \dontrun{
#' rcon <- redcapConnection(url = [YOUR_REDCAP_URL], 
#'                          token = [API_TOKEN])
#' 
#' exportRecords(rcon)
#' 
#' # Get the complete metadata for the project
#' rcon$metadata()
#' 
#' # Get the fieldnames for a project
#' rcon$fieldnames()
#' 
#' # remove a cached value for fieldnames
#' rcon$flush_fieldnames()
#' rcon$has_fieldnames()
#' 
#' 
#' # Using offline connections
#' 
#' meta_data_file <- "path/to/meta_data_file.csv"
#' records_file <- "path/to/records_file.csv"
#' events_file <- "path/to/events_file.csv"
#' 
#' ProjectInfo <- data.frame(project_id = 12345, 
#'                           is_longitudinal = 1)
#' 
#' off_conn <- offlineConnection(meta_data = meta_data_file, 
#'                               records = records_file,
#'                               project_info = ProjectInfo, 
#'                               version = [YOUR_REDCAP_VERSION_NUMBER], 
#'                               url = [YOUR_REDCAP_URL])
#'                               
#' off_conn$metadata()
#' off_conn$records()
#' off_conn$projectInformation()
#' off_conn$version()
#' 
#' # Add or replace the data in the events component.
#' off_conn$refresh_events(events_file)
#' off_conn$events()
#' }
#' 
#' @export

redcapConnection <- function(url = getOption('redcap_api_url'),
                             token,
                             config = httr::config(), 
                             retries = 5, 
                             retry_interval = 2^(seq_len(retries)), 
                             retry_quietly = TRUE)
{
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert_character(x = url, 
                              len = 1, 
                              add = coll)
  
  checkmate::assert_character(x = token, 
                              len = 1, 
                              add = coll)
  
  checkmate::assert_integerish(x = retries, 
                               len = 1, 
                               lower = 1, 
                               any.missing = FALSE, 
                               add = coll)
  
  checkmate::assert_numeric(x = retry_interval, 
                            lower = 0,
                            any.missing = FALSE, 
                            add = coll)
  
  checkmate::assert_logical(x = retry_quietly, 
                            len = 1, 
                            any.missing = FALSE, 
                            add = coll)
  
  checkmate::reportAssertions(coll)
  
  u <- url
  t <- token
  this_metadata <- NULL
  this_arm <- NULL
  this_event <- NULL
  this_fieldname <- NULL
  this_mapping <- NULL
  this_user <- NULL
  this_version <- NULL
  this_project <- NULL
  this_instrument <- NULL
  this_fileRepository <- NULL
  this_repeat <- NULL
  this_dag <- NULL
  this_dag_assign <- NULL
  this_user_role <- NULL
  this_user_role_assign <- NULL
  this_ec <- NULL #external coding
  
  rtry <- retries
  rtry_int <- rep(retry_interval, 
                  length.out = rtry)
  rtry_q <- retry_quietly
  
  getter <- function(export, ...){
    switch(export, 
           "metadata" = exportMetaData(rc), 
           "arm" = exportArms(rc), 
           "event" = exportEvents(rc),
           "fieldname" = exportFieldNames(rc), 
           "mapping" = exportMappings(rc), 
           "user" = exportUsers(rc), 
           "version" = exportVersion(rc), 
           "project" = exportProjectInformation(rc), 
           "instrument" = exportInstruments(rc), 
           "fileRepo" = exportFileRepositoryListing(rc, recursive = TRUE),
           "repeat" = exportRepeatingInstrumentsEvents(rc),
           "dags" = exportDags(rc),
           "dagAssign" = exportUserDagAssignments(rc),
           "userRole" = exportUserRoles(rc),
           "userRoleAssign" = exportUserRoleAssignments(rc),
           "externalCoding" = exportExternalCoding(rc, ...),
           NULL)
  }
  
  rc <- 
    list(
      url = u, 
      token = t, 
      config = config, 
      
      metadata = function(){ if (is.null(this_metadata)) this_metadata <<- getter("metadata"); this_metadata }, 
      has_metadata = function() !is.null(this_metadata),
      flush_metadata = function() this_metadata <<- NULL, 
      refresh_metadata = function() this_metadata <<- getter("metadata"), 
      
      arms = function(){ if (is.null(this_arm)) this_arm <<- getter("arm"); this_arm }, 
      has_arms = function() !is.null(this_arm), 
      flush_arms = function() this_arm <<- NULL, 
      refresh_arms = function() this_arm <<- getter("arm"), 
      
      events = function(){ if (is.null(this_event)) this_event <<- getter("event"); this_event}, 
      has_events = function() !is.null(this_event), 
      flush_events = function() this_event <<- NULL, 
      refresh_events = function() this_event <<- getter("event"), 
      
      fieldnames = function(){ if (is.null(this_fieldname)) this_fieldname <<- getter("fieldname"); this_fieldname }, 
      has_fieldnames = function() !is.null(this_fieldname), 
      flush_fieldnames = function() this_fieldname <<- NULL, 
      refresh_fieldnames = function() this_fieldname <<- getter("fieldname"), 
      
      mapping = function(){ if (is.null(this_mapping)) this_mapping <<- getter("mapping"); this_mapping }, 
      has_mapping = function() !is.null(this_mapping), 
      flush_mapping = function() this_mapping <<- NULL, 
      refresh_mapping = function() this_mapping <<- getter("mapping"), 
      
      users = function(){ if (is.null(this_user)) this_user <<- getter("user"); this_user }, 
      has_users = function() !is.null(this_user), 
      flush_users = function() this_user <<- NULL, 
      refresh_users = function() this_user <<- getter("user"), 
      
      user_roles = function(){ if (is.null(this_user_role)) this_user_role <<- getter("userRole"); this_user_role },
      has_user_roles = function() !is.null(this_user_role),
      flush_user_roles = function() this_user_role <<- NULL, 
      refresh_user_roles = function() this_user_role <<- getter("userRole"),
      
      user_role_assignment = function(){ if (is.null(this_user_role_assign)) this_user_role_assign <<- getter("userRoleAssign"); this_user_role_assign },
      has_user_role_assignment = function() !is.null(this_user_role_assign),
      flush_user_role_assignment = function() this_user_role_assign <<- NULL, 
      refresh_user_role_assignment = function() this_user_role_assign <<- getter("userRoleAssign"), 
      
      version = function(){ if (is.null(this_version)) this_version <<- getter("version"); this_version }, 
      has_version = function() !is.null(this_version), 
      flush_version = function() this_version <<- NULL, 
      refresh_version = function() this_version <<- getter("version"), 
      
      projectInformation = function(){ if (is.null(this_project)) this_project <<- getter("project"); this_project }, 
      has_projectInformation = function() !is.null(this_project), 
      flush_projectInformation = function() this_project <<- NULL, 
      refresh_projectInformation = function() this_project <<- getter("project"), 
      
      instruments = function(){ if (is.null(this_instrument)) this_instrument <<- getter("instrument"); this_instrument },
      has_instruments = function() !is.null(this_instrument), 
      flush_instruments = function() this_instrument <<- NULL, 
      refresh_instruments = function() this_instrument <<- getter("instrument"), 
      
      fileRepository = function(){ if (is.null(this_fileRepository)) this_fileRepository <<- getter("fileRepo"); this_fileRepository },
      has_fileRepository = function() !is.null(this_fileRepository),
      flush_fileRepository = function() this_fileRepository <<- NULL,
      refresh_fileRepository = function() this_fileRepository <<- getter("fileRepo"),
      
      repeatInstrumentEvent = function(){ if (is.null(this_repeat)) this_repeat <<- getter("repeat"); this_repeat }, 
      has_repeatInstrumentEvent = function() !is.null(this_repeat),
      flush_repeatInstrumentEvent = function() this_repeat <<- NULL,
      refresh_repeatInstrumentEvent = function() this_repeat <<- getter("repeat"),
      
      dags = function() {if (is.null(this_dag)) this_dag <<- getter("dags"); this_dag },
      has_dags = function() !is.null(this_dag), 
      flush_dags = function() this_dag <<- NULL, 
      refresh_dags = function() this_dag <<- getter("dags"),
      
      dag_assignment = function() {if (is.null(this_dag_assign)) this_dag_assign <<- getter("dagAssign"); this_dag_assign },
      has_dag_assignment = function() !is.null(this_dag_assign), 
      flush_dag_assignment = function() this_dag_assign <<- NULL, 
      refresh_dag_assignment = function() this_dag_assign <<- getter("dagAssign"),
      
      externalCoding = function(...) {if (is.null(this_ec)) this_ec <<- getter("externalCoding", ...); this_ec}, 
      has_externalCoding = function() !is.null(this_ec), 
      flush_externalCoding = function() this_ec <<- NULL, 
      refresh_externalCoding = function(...) this_ec <<- getter("externalCoding", ...),
      
      flush_all = function(){ 
        this_metadata <<- 
          this_arm <<- this_event <<- 
          this_instrument <<- this_fieldname <<- this_mapping <<-
          this_repeat <<- 
          this_user <<- this_user_role <<- this_user_role_assign <<-
          this_dag <<- this_dag_assign <<-
          this_project <<- this_version <<-
          this_fileRepository <<- 
          this_ec <<-
          NULL}, 
      
      refresh_all = function(){
        this_metadata <<- getter("metadata")
        this_arm <<- getter("arm")
        this_event <<- getter("event")
        this_instrument <<- getter("instrument")
        this_fieldname <<- getter("fieldname")
        this_mapping <<- getter("mapping")
        this_repeat <<- getter("repeat")
        this_user_role <<- getter("userRole")
        this_user_role_assign <<- getter("userRoleAssign")
        this_dag <<- getter("dag")
        this_dag_assign <<- getter("dagAssign")
        this_project <<- getter("project")
        this_version <<- getter("version")
        this_fileRepository <<- getter("fileRepo")
        this_ec <<- getter("externalCoding")
        
      },
      
      retries = function() rtry, 
      set_retries = function(r){
        checkmate::assert_integerish(x = r, 
                                     len = 1, 
                                     lower = 1,
                                     any.missing = FALSE) 
        rtry <<- r
      },
      
      retry_interval = function() rtry_int, 
      set_retry_interval = function(ri){
        checkmate::assert_numeric(x = ri, 
                                  lower = 0,
                                  any.missing = FALSE)
        rtry_int <<- rep(ri, length.out = rtry)
      }, 
      
      retry_quietly = function() rtry_q, 
      set_retry_quietly = function(rq){
        checkmate::assert_logical(x = rq, 
                                  len = 1, 
                                  any.missing = FALSE)
        rtry_q <<- rq
      }
    )
  class(rc) <- c("redcapApiConnection", "redcapConnection")
  rc
}

#' @rdname redcapConnection
#' @export

print.redcapApiConnection <- function(x, ...){
  is_cached <- function(l) if (l) "Cached" else "Not Cached" 

  output <- 
    c("REDCap API Connection Object", 
      sprintf("Meta Data            : %s", is_cached(x$has_metadata())), 
      sprintf("Arms                 : %s", is_cached(x$has_arms())),
      sprintf("Events               : %s", is_cached(x$has_events())), 
      sprintf("Instruments          : %s", is_cached(x$has_instruments())),
      sprintf("Field Names          : %s", is_cached(x$has_fieldnames())), 
      sprintf("Mapping              : %s", is_cached(x$has_mapping())),
      sprintf("Repeat Inst.         : %s", is_cached(x$has_repeatInstrumentEvent())),
      sprintf("Users                : %s", is_cached(x$has_users())), 
      sprintf("User Roles           : %s", is_cached(x$has_user_roles())),
      sprintf("User-Role Assignment : %s", is_cached(x$has_user_role_assignment())),
      sprintf("DAGs                 : %s", is_cached(x$has_dags())),
      sprintf("DAG Assignment       : %s", is_cached(x$has_dag_assignment())),
      sprintf("Project Info         : %s", is_cached(x$has_projectInformation())),
      sprintf("Version              : %s", is_cached(x$has_version())),  
      sprintf("File Repo            : %s", is_cached(x$has_fileRepository())), 
      sprintf("External Coding      : %s", is_cached(x$has_externalCoding())))
  cat(output, sep = "\n")
}

#' @rdname redcapConnection
#' @param meta_data Either a `character` giving the file from which the 
#'   metadata can be read, or a `data.frame`.
#' @param arms Either a `character` giving the file from which the 
#'   arms can be read, or a `data.frame`.
#' @param events Either a `character` giving the file from which the 
#'   events can be read, or a `data.frame`.
#' @param instruments Either a `character` giving the file from which the 
#'   instruments can be read, or a `data.frame`.
#' @param field_names Either a `character` giving the file from which the 
#'   field names can be read, or a `data.frame`.
#' @param mapping Either a `character` giving the file from which the 
#'   Event Instrument mappings can be read, or a `data.frame`.
#' @param repeat_instrument Either a `character` giving the file from which the 
#'   Repeating Instruments and Events settings can be read, or a `data.frame`.
#'   Note: The REDCap GUI does not offer a download file of these settings 
#'   (at the time of this writing).
#' @param users Either a `character` giving the file from which the 
#'   User settings can be read, or a `data.frame`.
#' @param user_roles Either a `character` giving the file from which the
#'   User Roles can be read, or a `data.frame`.
#' @param user_role_assignment Either a `character` giving the file from which the
#'   User-Role Assignments can be read, or a `data.frame`. 
#' @param dags Either a `character` giving the file from which the 
#'   Data Access Groups can be read, or a `data.frame`.
#' @param dag_assignment Either a `character` giving the file from which the
#'   Data Access Group Assignments can be read, or a `data.frame`.
#' @param project_info Either a `character` giving the file from which the 
#'   Project Information can be read, or a `data.frame`. See Details.
#' @param version `character(1)` giving the instance's REDCap version number.
#' @param file_repo Either a `character` giving the file from which the 
#'   File Repository Listing can be read, or a `data.frame`.
#' @param records Either a `character` giving the file from which the 
#'   Records can be read, or a `data.frame`. This should be the raw 
#'   data as downloaded from the API, for instance. Using labeled or formatted
#'   data is likely to result in errors when passed to other functions.
#' @param external_coding Named `list` of named `character` vectors or a 
#'   `character` giving the file from which the external coding may 
#'   be read. The list is generally obtained from the API using 
#'   [exportExternalCoding()]. The name of the list element should be 
#'   a field name in the data that is of type `bioportal` or `sql`. 
#'   The named vectors are code-label pairings where the value of the 
#'   vector is the code and the name is the label. If passing a file name, 
#'   it should be a file with the list saved via `dput`. 
#'   
#' @export

offlineConnection <- function(meta_data = NULL, 
                              arms = NULL, 
                              events = NULL, 
                              instruments = NULL, 
                              field_names = NULL, 
                              mapping = NULL, 
                              repeat_instrument = NULL,
                              users = NULL, 
                              user_roles = NULL, 
                              user_role_assignment = NULL,
                              dags = NULL, 
                              dag_assignment = NULL,
                              project_info = NULL, 
                              version = NULL, 
                              file_repo = NULL,
                              records = NULL, 
                              url = NULL, 
                              external_coding = list()){
  ###################################################################
  # Argument Validation                                          ####
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert(
    checkmate::check_character(x = meta_data, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = meta_data, 
                                null.ok = TRUE), 
    combine = "or",
    .var.name = "meta_data", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = arms, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = arms, 
                                null.ok = TRUE), 
    .var.name = "arms", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = events, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = events, 
                                null.ok = TRUE), 
    .var.name = "events", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = instruments, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = instruments, 
                                null.ok = TRUE), 
    .var.name = "instruments", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = field_names, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = field_names, 
                                null.ok = TRUE), 
    .var.name = "field_names", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = mapping, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = mapping, 
                                null.ok = TRUE), 
    .var.name = "mapping", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = repeat_instrument, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = repeat_instrument, 
                                null.ok = TRUE), 
    .var.name = "repeat_instrument", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = users, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = users, 
                                null.ok = TRUE), 
    .var.name = "users", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = user_roles, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = user_roles, 
                                null.ok = TRUE), 
    .var.name = "user_roles", 
    add = coll
  )

  checkmate::assert(
    checkmate::check_character(x = user_role_assignment, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = user_role_assignment, 
                                null.ok = TRUE), 
    .var.name = "user_role_assignment", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = dags, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = dags, 
                                null.ok = TRUE), 
    .var.name = "dags", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = dag_assignment, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = dag_assignment, 
                                null.ok = TRUE), 
    .var.name = "dag_assignment", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = project_info, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = project_info, 
                                null.ok = TRUE), 
    .var.name = "project_info", 
    add = coll
  )
  
  checkmate::assert_character(x = version, 
                              len = 1, 
                              null.ok = TRUE, 
                              add = coll)
  
  checkmate::assert(
    checkmate::check_character(x = file_repo, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = file_repo, 
                                null.ok = TRUE), 
    .var.name = "file_repo", 
    add = coll
  )
  
  checkmate::assert(
    checkmate::check_character(x = records, 
                               len = 1, 
                               null.ok = TRUE), 
    checkmate::check_data_frame(x = records, 
                                null.ok = TRUE), 
    .var.name = "records", 
    add = coll
  )
  
  checkmate::assert_character(x = url, 
                              len = 1, 
                              null.ok = TRUE,
                              add = coll)
  
  checkmate::assert(
    checkmate::check_list(x = external_coding,
                          types = "character",
                          names = "named", 
                          null.ok = TRUE), 
    checkmate::check_character(x = external_coding, 
                               len = 1, 
                               null.ok = TRUE), 
    .var.name = "external_coding", 
    add = coll
  )
  
  checkmate::reportAssertions(coll)
  
  if (is.list(external_coding) && length(external_coding) > 0){
    for (i in seq_along(external_coding)){
      checkmate::assert_character(x = external_coding[[i]], 
                                  names = "named", 
                                  add = coll)
    }
  }
  
  checkmate::reportAssertions(coll)
  
  ###################################################################
  # Argument Validation - Part Two                               ####
  
  if (is.character(meta_data)){
    checkmate::assert_file_exists(x = meta_data, 
                                  add = coll)
  }
  
  if (is.character(arms)){
    checkmate::assert_file_exists(x = arms, 
                                  add = coll)
  }
  
  if (is.character(events)){
    checkmate::assert_file_exists(x = events, 
                                  add = coll)
  }
  
  if (is.character(instruments)){
    checkmate::assert_file_exists(x = instruments, 
                                  add = coll)
  }
  
  if (is.character(field_names)){
    checkmate::assert_file_exists(x = field_names, 
                                  add = coll)
  }
  
  if (is.character(mapping)){
    checkmate::assert_file_exists(x = mapping, 
                                  add = coll)
  }
  
  if (is.character(repeat_instrument)){
    checkmate::assert_file_exists(x = repeat_instrument, 
                                  add = coll)
  }
  
  if (is.character(users)){
    checkmate::assert_file_exists(x = users, 
                                  add = coll)
  }
  
  if (is.character(user_roles)){
    checkmate::assert_file_exists(x = user_roles, 
                                  add = coll)
  }

  if (is.character(user_role_assignment)){
    checkmate::assert_file_exists(x = user_role_assignment, 
                                  add = coll)
  }
  
  if (is.character(dags)){
    checkmate::assert_file_exists(x = dags, 
                                  add = coll)
  }
  
  if (is.character(dag_assignment)){
    checkmate::assert_file_exists(x = dag_assignment, 
                                  add = coll)
  }
  
  if (is.character(project_info)){
    checkmate::assert_file_exists(x = project_info, 
                                  add = coll)
  }
  
  if (is.character(file_repo)){
    checkmate::assert_file_exists(x = file_repo, 
                                  add = coll)
  }
  
  if (is.character(external_coding)){
    checkmate::assert_file_exists(x = external_coding, 
                                  add = coll)
  }
  
  checkmate::reportAssertions(coll)
  
  ###################################################################
  # Read files                                                   ####
  this_metadata <- 
    validateRedcapData(data = .offlineConnection_readMetaData(meta_data), 
                       redcap_data = REDCAP_METADATA_STRUCTURE)
  this_arm <- 
    validateRedcapData(data = .offlineConnection_readFile(arms), 
                       redcap_data = REDCAP_ARMS_STRUCTURE)
  this_event <- 
    validateRedcapData(data = .offlineConnection_readFile(events), 
                       redcap_data = REDCAP_EVENT_STRUCTURE)
  this_fieldname <- 
    if (is.null(field_names) & !is.null(this_metadata)){
      .fieldNamesFromMetaData(this_metadata)
    } else {
      validateRedcapData(data = .offlineConnection_readFile(field_names), 
                         redcap_data = REDCAP_FIELDNAME_STRUCTURE)
    }
  this_mapping <- 
    validateRedcapData(data = .offlineConnection_readFile(mapping), 
                       redcap_data = REDCAP_INSTRUMENT_MAPPING_STRUCTURE)

  this_repeat <- .offlineConnection_readFile(repeat_instrument)
  
  this_user <- 
    validateRedcapData(data = .offlineConnection_readFile(users), 
                       redcap_data = redcapUserStructure(version))
  this_user_roles <- 
    validateRedcapData(data = .offlineConnection_readFile(user_roles), 
                       redcap_data = REDCAP_USER_ROLE_STRUCTURE)
  this_user_role_assignment <- 
    validateRedcapData(data = .offlineConnection_readFile(user_role_assignment), 
                       redcap_data = REDCAP_USER_ROLE_ASSIGNMENT_STRUCTURE)
  this_dags <- 
    validateRedcapData(data = .offlineConnection_readFile(dags),
                       redcap_data = REDCAP_DAG_STRUCTURE)
  this_dag_assignment <- 
    validateRedcapData(data = .offlineConnection_readFile(dag_assignment), 
                       redcap_data = REDCAP_DAG_ASSIGNMENT_STRUCTURE)
  this_project <- 
    validateRedcapData(data = .offlineConnection_readFile(project_info), 
                       redcap_data = REDCAP_PROJECT_INFORMATION_STRUCTURE)
  this_version <- version

  this_fileRepository <- .offlineConnection_readFile(file_repo)
  
  this_ec <- 
    if (is.list(external_coding)){
      external_coding
    } else {
      eval(parse(file = external_coding))
    }

  
  this_instrument <- 
    if (is.null(instruments) & !is.null(this_metadata)){
      data.frame(instrument_name = unique(this_metadata$form_name), 
                 instrument_label = unique(this_metadata$form_name), 
                 stringsAsFactors = FALSE)
    } else {
      validateRedcapData(data = .offlineConnection_readFile(instruments), 
                         redcap_data = REDCAP_INSTRUMENT_STRUCTURE)
    }
  
  this_record <- .offlineConnection_readFile(records)
  
  ###################################################################
  # Redcap Connection object                                     ####
  rc <- 
    list(
      url = url, 
      token = NULL, 
      config = NULL, 
      
      metadata = function(){ this_metadata }, 
      has_metadata = function() !is.null(this_metadata),
      flush_metadata = function() this_metadata <<- NULL, 
      refresh_metadata = function(x) {this_metadata <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                           redcap_data = REDCAP_METADATA_STRUCTURE)}, 
      
      arms = function(){ this_arm }, 
      has_arms = function() !is.null(this_arm), 
      flush_arms = function() this_arm <<- NULL, 
      refresh_arms = function(x) {this_arm <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                  redcap_data = REDCAP_ARMS_STRUCTURE)}, 
      
      events = function(){ this_event}, 
      has_events = function() !is.null(this_event), 
      flush_events = function() this_event <<- NULL, 
      refresh_events = function(x) {this_event <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                      redcap_data = REDCAP_EVENT_STRUCTURE)}, 
      
      instruments = function(){ this_instrument },
      has_instruments = function() !is.null(this_instrument), 
      flush_instruments = function() this_instrument <<- NULL, 
      refresh_instruments = function(x) {
        this_instrument <<- 
          if (is.null(x) & !is.null(this_metadata)){
            data.frame(instrument_name = unique(this_metadata$form_name), 
                       instrument_label = unique(this_metadata$form_name), 
                       stringsAsFactors = FALSE)
          } else {
            validateRedcapData(data = .offlineConnection_readFile(x), 
                               redcap_data = REDCAP_INSTRUMENT_STRUCTURE)
          }
      }, 
      
      fieldnames = function(){ this_fieldname }, 
      has_fieldnames = function() !is.null(this_fieldname), 
      flush_fieldnames = function() this_fieldname <<- NULL, 
      refresh_fieldnames = function(x = NULL) {
        this_fieldname <<- 
          if (is.null(x) & !is.null(this_metadata)){
            .fieldNamesFromMetaData(this_metadata)
          } else {
            validateRedcapData(data = .offlineConnection_readFile(x), 
                               redcap_data = REDCAP_FIELDNAME_STRUCTURE)
          }
      }, 
      
      mapping = function(){ this_mapping }, 
      has_mapping = function() !is.null(this_mapping), 
      flush_mapping = function() this_mapping <<- NULL, 
      refresh_mapping = function(x) { this_mapping <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                          redcap_data = REDCAP_INSTRUMENT_MAPPING_STRUCTURE)}, 
      
      repeatInstrumentEvent = function(){ this_repeat }, 
      has_repeatInstrumentEvent = function() !is.null(this_repeat), 
      flush_repeatInstrumentEvent = function() this_project <<- NULL, 
      refresh_repeatInstrumentEvent = function(x) {this_project <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                                       redcap_data = REDCAP_REPEAT_INSTRUMENT_STRUCTURE)},
                                                                                       
      users = function(){ this_user }, 
      has_users = function() !is.null(this_user), 
      flush_users = function() this_user <<- NULL, 
      refresh_users = function(x) {this_user <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                    redcap_data = redcapUserStructure(this_version))}, 
      
      user_roles = function(){ this_user_roles }, 
      has_user_roles = function() !is.null(this_user_roles), 
      flush_user_roles = function() this_user_roles <<- NULL, 
      refresh_user_roles = function(x) {this_user_roles <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                               redcap_data = REDCAP_USER_ROLE_STRUCTURE)}, 
      
      users_role_assignment = function(){ this_user_role_assignment }, 
      has_user_role_assignment = function() !is.null(this_user_role_assignment), 
      flush_user_role_assignment = function() this_user_role_assignment <<- NULL, 
      refresh_user_role_assignment = function(x) {this_user_role_assignment <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                                                   redcap_data = REDCAP_USER_ROLE_ASSIGNMENT_STRUCTURE)}, 
      
      dags = function(){ this_dags }, 
      has_dags = function() !is.null(this_dags), 
      flush_dags = function() this_dags <<- NULL, 
      refresh_dags = function(x) {this_dags <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                  redcap_data = REDCAP_DAG_STRUCTURE)},
      
      dag_assignment = function(){ this_dag_assignment }, 
      has_dag_assignment = function() !is.null(this_dag_assignment), 
      flush_dag_assignment = function() this_dag_assignment <<- NULL, 
      refresh_dag_assignment = function(x) {this_dag_assignment <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                                       redcap_data = REDCAP_DAG_ASSIGNMENT_STRUCTURE)},
      
      projectInformation = function(){ this_project }, 
      has_projectInformation = function() !is.null(this_project), 
      flush_projectInformation = function() this_project <<- NULL, 
      refresh_projectInformation = function(x) {this_project <<- validateRedcapData(data = .offlineConnection_readFile(x), 
                                                                                    redcap_data = REDCAP_PROJECT_INFORMATION_STRUCTURE)}, 
      
      version = function(){ this_version }, 
      has_version = function() !is.null(this_version), 
      flush_version = function() this_version <<- NULL, 
      refresh_version = function(x) {this_version <<- x}, 
      
      fileRepository = function(){ this_fileRepository },
      has_fileRepository = function() !is.null(this_fileRepository),
      flush_fileRepository = function() this_fileRepository <<- NULL,
      refresh_fileRepository = function(x) {this_fileRepository <<- .offlineConnection_readFile(x)},
      
      records = function(){ this_record },
      has_records = function() !is.null(this_record),
      flush_records = function() this_record <<- NULL,
      refresh_records = function(x) {this_record <<- .offlineConnection_readFile(records)},
      
      externalCoding = function(...){ this_ec }, 
      has_externalCoding = function() !is.null(this_ec), 
      flush_externalCoding = function() this_ec <<- NULL,
      refresh_externalCoding = function(x, ...) {this_ec <<- x},
      
      flush_all = function(){ 
        this_metadata <<- this_arm <<- this_event <<- this_fieldname <<- 
          this_mapping <<- this_user <<- this_version <<- this_project <<- 
          this_instrument <<- this_fileRepository <<- this_repeat <<- 
          this_ec <<- NULL}, 
      
      refresh_all = function(){} # provided only to match the redcapApiConnection. Has no effect
    )
  class(rc) <- c("redcapOfflineConnection", "redcapConnection")
  rc
}

#' @rdname redcapConnection
#' @export

print.redcapOfflineConnection <- function(x, ...){
    is_cached <- function(l) if (l) "Cached" else "Not Cached" 
    
    output <- 
      c("REDCap Offline Connection Object", 
        sprintf("Records               : %s", is_cached(x$has_records())),
        sprintf("Meta Data             : %s", is_cached(x$has_metadata())), 
        sprintf("Arms                  : %s", is_cached(x$has_arms())), 
        sprintf("Events                : %s", is_cached(x$has_events())),
        sprintf("Instruments           : %s", is_cached(x$has_instruments())),
        sprintf("Field Names           : %s", is_cached(x$has_fieldnames())), 
        sprintf("Mapping               : %s", is_cached(x$has_mapping())),
        sprintf("Repeat Inst.          : %s", is_cached(x$has_repeatInstrumentEvent())),
        sprintf("Users                 : %s", is_cached(x$has_users())),
        sprintf("User Roles            : %s", is_cached(x$has_user_roles())),
        sprintf("Users Role Assignment : %s", is_cached(x$has_user_role_assignment())),
        sprintf("DAGs                  : %s", is_cached(x$has_dags())),
        sprintf("DAG Assigment         : %s", is_cached(x$has_dag_assignment())),
        sprintf("Project Info          : %s", is_cached(x$has_projectInformation())), 
        sprintf("Version               : %s", is_cached(x$has_version())), 
        sprintf("File Repo             : %s", is_cached(x$has_fileRepository())), 
        sprintf("External Coding       : %s", is_cached(x$has_externalCoding())))
    cat(output, sep = "\n")
}

#####################################################################
# Unexported

.offlineConnection_readFile <- function(file){
  if (is.character(file)){
    utils::read.csv(file, 
                    na.strings = "", 
                    stringsAsFactors = FALSE, 
                    colClasses = "character")
  } else {
    file
  }
}

.fieldNamesFromMetaData <- function(meta_data){
  FieldNameFrame <- 
    mapply(
      function(field_name, field_type, choices){
        if (field_type == "checkbox"){
          mapping <- fieldChoiceMapping(choices, field_name)
          data.frame(original_field_name = rep(field_name, nrow(mapping)), 
                     choice_value = mapping[, 1], 
                     export_field_name = sprintf("%s___%s", 
                                                 field_name, 
                                                 tolower(mapping[, 1])), 
                     stringsAsFactors = FALSE)
        } else {
          data.frame(original_field_name = field_name, 
                     choice_value = NA_character_, 
                     export_field_name = field_name, 
                     stringsAsFactors = FALSE)
        }
      }, 
      field_name = meta_data$field_name, 
      field_type = meta_data$field_type, 
      choices = meta_data$select_choices_or_calculations, 
      SIMPLIFY = FALSE)
  
  forms <- unique(meta_data$form_name)
  forms <- sprintf("%s_complete", forms)
  FormFieldName <- data.frame(original_field_name = forms, 
                              choice_value = NA_character_, 
                              export_field_name = forms, 
                              stringsAsFactors = FALSE)
  
  FieldNames <- do.call("rbind", FieldNameFrame)
  FieldNames <- rbind(FieldNames, FormFieldName)
  rownames(FieldNames) <- NULL
  FieldNames
}

.offlineConnection_readMetaData <- function(file){
  if (is.character(file)){
    MetaData <- utils::read.csv(file, 
                                na.strings = "", 
                                stringsAsFactors = FALSE)
    
    names(MetaData) <- 
      ifelse(names(MetaData) %in% names(REDCAP_METADATA_API_UI_MAPPING), 
             REDCAP_METADATA_API_UI_MAPPING[names(MetaData)], 
             names(MetaData))
    
    return(MetaData)
  } else {
    file
  }
}
nutterb/redcapAPI documentation built on Feb. 11, 2024, 11:20 p.m.