R/atri_docs_download.R

In rg08705/test: Tools for sourcing and exporting ATRI Data

#' Directly download a Docs file from standard topic
#'
#' Download a Docs file from a standard topic-code by file label
#'
#' @param protocol: The protocol name (e.g. 'a345').
#' @param topic: The url topic code that the file is listed in.
#' @param file_label: The label name of the file in the topic. Entered value is allowed to be a fixed and case-sensitive substring of the full file label.
#' @param file: (optional; if no value entered, filename will be automatically generated by full file label and file extension based on file_type metadata.) File path of the downloaded file.
#' @param out_dir: (optional; valid only when optional 'file' parameter is not entered) Output location for downloaded file. If no value entered, then current working directory is used.
#' @param site_code: (optional) Required for site-restricted topics. The site code of the site that the user can access.
#' @param sort_first: (optional) File downloaded will be the first record in the list of files based on the sorting of the allowable character parameter entered. Allowable parameters include: label, code, ts_last_modify, ts_create, ts_file_last_modify, file_size, file_type (descending order can be prefixed with '-'; e.g. '-label').
#' @return atri_api object containing: response- response from http url; url- a string of complete url; protocol- a string of input protocol; filename- name of downloaded file.
#' @seealso \code{\link{atri_api}}
#' @examples
#' \donttest{
#' # Download file
#' atri_docs_download(protocol='a345', topic='transfer-invicro', file_label='A3-45 Participant List')
#' # Source downloaded file
#' resp<-atri_docs_download(protocol='a345', topic='transfer-invicro', file_label='A3-45 Participant List')
#' pt.list<-read.csv(resp$filename)
#' 
#' # Download file from site-restricted topic
#' atri_docs_download(protocol='a345', topic='site-reports-screening-enrollment-log', file_label='Enrollment_Log', site_code='002')
#' 
#' # Download file based on first record in sorted list of files
#' atri_docs_download(protocol='a345', topic='transfer-oracle', file_label='actc_prod_', sort_first='-ts_create') #Newest
#' atri_docs_download(protocol='a345', topic='transfer-oracle', file_label='actc_prod_', sort_first='ts_create') #Oldest
#' }
#' @export

atri_docs_download <- function(protocol, topic, file_label, file=NA, out_dir=NULL, site_code=NULL, sort_first=NULL) {
  protocol_url <- paste0("https://", protocol, ".atrihub.org")
  url <- paste0("/public/api/v1/docs/topics/",topic,"/files?format=json")
  if (!is.null(site_code)) {
    url <- paste0(url, "&site_code=",site_code)
  }
  if (!is.null(sort_first)) {
    url <- paste0(url, "&sort=",sort_first)
  }
  x<-atri_api(protocol, path=url, direct=TRUE) #grab list of items
  y<-x[grepl(file_label,x$label,fixed=T),] #subset items which file_label is a substring of label
  if (nrow(y)==0) { #if no results match label
    stop(paste0("file_label entered does not match any result within topic."))
  } else if (nrow(y)>1 & is.null(sort_first)) { # else if >1 result, sort_first must have a value to download file
    stop(paste0(nrow(y)," results in the topic match the file_label. Consider using sort_first to source the first sorted result."))
  } else {#else (if 1 result OR >1 result and sort_first has value)
    if (is.na(file)){
      if (grepl('.',y$label[1],fixed=T)) { #if file extension already is in label use file label
        file<-y$label[1]
      } else{
        if (is.na(y$file_type[1])) { #if file type is unknown in metadata, then error
          stop(paste0("file type is unknown in file metadata. Enter filename with file extension using the function's file parameter"))
        } else { #maps file_type to valid file extension. See mimemap.rdata in package's 'data' folder
          y$file_type[1]<-mimemap[y$file_type[1]]
          file<-paste(y$label[1], y$file_type[1],sep='.')
        }
      }
      if (!is.null(out_dir)){
        file<-paste0(out_dir,'/',file)
      }
    }
    url<-paste0(protocol_url,y$latest_version.download_url[1])
    if (!is.null(site_code)) {
      url <- paste0(url, "&site_code=",site_code)
    }
    resp <- httr::GET(url, httr::add_headers(Authorization = paste("Token", grab_token(protocol))),
                      httr::write_disk(file, overwrite = TRUE))
    if(resp$status_code >= 400) {#if unsuccessful, will try request once more with authorization included in URL
      resp<- httr::GET(resp$url, httr::write_disk(file, overwrite = TRUE))
    }
    httr::warn_for_status(resp)
    if(resp$status_code >= 400) #if unsuccessful, print error
      stop(paste0("invalid http status code:", resp$status_code,
                  ", check token, connection, api documentation and ", url))
    structure(list(response = resp, url = url, protocol = protocol, filename=file),
              class = "atri_api")
  }
}