R/other-methods.R

In dirkschumacher/RBerlinData: Easy access to Berlin related data

### miscellaneous S3 methods ###
# for classes outside of the berlin_data_* pattern

## methods for BerlinData generic functions ##

# see also getDatasetMetaData.berlin_data_dataset_info
#' @export
getDatasetMetaData.character = function(where, ...) {
  stopifnot(length(where) == 1)
  result <- parseMetaData(where, ...)
  result
}

# these methods are for classes are generated by download.berlin_data_resource
# see also download.berlin_data_resource

#' Default fallback method for download
#' Indicates unsupported file format
#' @param x a resource which can be downloaded
#' @param ... optional additional arguments
#' @param message.on.fail logical: show message indicating failure to download?
#' @export
download.default <- function(x, message.on.fail=TRUE, ...) {
  stopifnot(length(x) >= 1)
  if(message.on.fail) {
    message('Attempted to download:')
    message(paste('  ', x))
    message('  File format:')
    message(paste('  ', class(x)))
    message('  Unfortunately, BerlinData does not currently support automatic download for this format.')    
  }
  return()
}

#' Downloads CSV
#' @param x url of csv file location
#' @param message.on.fail logical: show message on download failure?
#' @param sep field separator
#' @param ... optional additional arguments to download function
#' @export
download.CSV <- function(x, message.on.fail=TRUE, ..., sep=';') {
  result <- tryCatch(read.csv(x, sep=sep, ...),
                     error = function(e) {
                       if(message.on.fail) {
                         message(paste("Failed to download resource:", x))
                         message("  Please try manual download.")
                         message(paste("  ", e, "\n"))
                       }
                       e
                     })
  if(inherits(result, "error")) return()
  result
}

#' Downloads TXT
#' @param x url of txt file location
#' @param sep field separator
#' @param message.on.fail logical: show message on download failure?
#' @param ... optional additional arguments to download function
#' @export
download.TXT <- function(x, message.on.fail=TRUE, ..., sep=',') {
  result <- tryCatch(read.csv(x, sep=sep, ...),
                     error = function(e) {
                       if(message.on.fail) {
                         message(paste("Failed to download resource:", x))
                         message("  Please try manual download.")
                         message(paste("  ", e, "\n")) 
                       }
                       e
                     })
  if(inherits(result, "error")) return()
  result
}


#' Downloads json file
#' @param x url of json file location
#' @param message.on.fail logical: show message on download failure?
#' @param parse.to.df logical: should the function try to parse the JSON output into a data.frame?
#' @param ... optional additional arguments to download function
#' @export
download.JSON <- function(x, message.on.fail=TRUE, ..., parse.to.df=TRUE) {
  result <- tryCatch(fromJSON(file=x, ...),
                     error = function(e) {
                       if(message.on.fail) {
                         message(paste("Failed to download resource:", x))
                         message("  Please try manual download.")
                         message(paste("  ", e, "\n")) 
                       }
                       e
                     })
  if(inherits(result, "error")) return()
  if(parse.to.df) {
    stopifnot(length(result) == 4 &
                names(result) == c("messages", "results", "index", "item") &
                class(result$index) == "list" & 
                length(result$index) >= 1)
    data <- result$index
    data <- lapply(data, unlist)
    data <- do.call(rbind, data)
    result <- data.frame(data) 
  }
  result
}

#' Downloads xml file
#' @param x url of xml file location
#' @param message.on.fail logical: show message on download failure?
#' @param parse.to.df logical: should the function try to parse the XML output into a data.frame?
#' @param ... optional additional arguments to download function
#' @export
download.XML = function(x, message.on.fail=TRUE, ..., parse.to.df=TRUE) {
  result <- tryCatch(xmlTreeParse(file=x, getDTD=FALSE, ...),
                     error = function(e) {
                       if(message.on.fail) {
                         message(paste("Failed to download resource:", x))
                         message("  Please try manual download.") 
                         message(paste("  ", e, "\n")) 
                       }
                       e
                     })
  if(inherits(result, "error")) return()
  stopifnot(length(result) == 3 &
              names(result) == c("file", "version", "children"))
  result <- xmlRoot(result)
  if (parse.to.df) {
    stopifnot("XMLNode" %in% class(result) &
                names(result) == c("messages", "results", "index", "item") & 
                length(result[['index']]) >= 1)
    items <- getNodeSet(result[['index']], "//item")
    ncols <- max(sapply(items, xmlSize))
    data <- lapply(items, 
                   function(item) {
                     datarow <- sapply(xmlChildren(item), xmlValue)
                     stopifnot(length(datarow) == ncols)
                     if(class(datarow)=="list") { #  handle missing values
                       datarow[sapply(datarow, length)==0] = ''
                       datarow <- unlist(datarow)
                     }
                     datarow
                   })
    data <- do.call(rbind, data)
    result <- data.frame(data)
  }
  result
}