#' @title Loads spatial data files
#'
#' @description \code{haawe} Downloads, organizes, and reprojects spatial data. Data may sourced from a reference dataframe provided in the package or alternatively specified by the user.
#'
#' @details stub
#'
#' @param x A keyword for the data to be loaded or alternatively the URL where the data is located
#' @param keyname The keyword to be assigned to the data in the case that x is a URL
#' @param overwrite A boolean value specifying whether previously loaded data may be overwritten
#'
#' @return No return value. A summary message statement is generated upon success.
#'
#' @author Edward Greg Huang <edwardgh@@berkeley.edu>
#' @export
haawe <- function(x, keyname = NULL, overwrite = FALSE) { # takes key/url and in case of url also a keyname argument
data(dataKeys, package = 'kokua') # Loads tracker dataframe of spacial data
if (is.null(keyname)) { # x is a key
keyData <- dataKeys[grep(x, dataKeys$key), ] # Searches for all data corresponding to x argument
if (nrow(keyData) == 0) { # Stop if there are no unloaded matches
stop('There are no unloaded data for the key specified')
}
if (overwrite == FALSE & ! is.null(getLoaded(x))) {
for (match in getLoaded(x)) {
message(match, ' is already loaded.')
}
message('')
keyData <- keyData[ ! keyData$key %in% getLoaded(x), ]
if (nrow(keyData) == 0) {
stop('All data for the specified query is already loaded. Overwrite not authorized.')
}
}
loadedData <- invisible(mapply(.loadData, keyData$url, keyData$key, .fileExt(keyData$url), file.path(.libPaths(), 'kokua', 'data'))) # Downloads each previously unloaded file with helper function
} else {
stopifnot(is.character(keyname)) # Verifies that keyname is a character string
if (overwrite == FALSE & ! is.null(getLoaded(keyname, exact == TRUE))) {
stop('Data is already loaded for the key specified. Overwrite not authorized.')
}
loadedData <- invisible(.loadData(x, keyname, .fileExt(x), dest = file.path(.libPaths(), 'kokua', 'data')))
}
message('Finished! New data loaded: ', sapply(loadedData, paste0, ' '))
message('All loaded data: ', sapply(getLoaded(), paste0, ' '))
}
.loadData <- function(url, name, ext, dest) {
filename <- paste(name, ext, sep = '.') # Constructs full filename
if (! file.exists(file.path(dest, name))) { # If folder does not exist in target directory
dir.create(file.path(dest, name)) # Creates new folder in the /data directory for file
}
path <- file.path(dest, filename) # Constructs filepath
message('Attempting to download ', name, '...')
attempt <- tryCatch(download.file(url = as.character(url), destfile = path, mode = 'wb'),
error = function(cond) {
message('Download failed for the URL: ', url)
message('Original error message:')
message(cond)
unlink(file.path(dest, name))
return(NULL)
}, warning = function(cond) {
message(cond)
message('')
return(NULL)
})# Downloads to target directory
if (is.null(attempt)) {
return(NULL)
}
if (length(unzip(path, list = TRUE)) > 0) { # Checks if file is compressed
unzip(path, exdir = file.path(dest, name)) # Unzips file to same directory and keeps original compressed file
file.remove(path) # Optional cleanup.
}
unlink(file.path(dest, name, '__MACOSX'), recursive = TRUE)
files <- list.files(path = file.path(dest, name) , recursive = TRUE)
fileInfo <- mapply(.readSelect, files, mapply(.fileExt, files))
fileInfo <- fileInfo[ ! sapply(fileInfo, is.null)]
stopifnot(length(fileInfo) == 1)
fileInfo <- unlist(fileInfo)
if (grepl("/", fileInfo[1], fixed = TRUE)) {
subdirectory <- gsub('/.*', '', fileInfo[1])
fileInfo[1] <- gsub('.*/', '', fileInfo[1])
} else {
subdirectory <- ''
}
readFun <- .scriptSelect(fileInfo[1], fileInfo[2])
loadString <- c(sprintf('oldwd <- setwd("%s")', paste0(file.path(dest, name, subdirectory))),
paste0(name, ' <- ', readFun),
.scriptSelect(fileInfo[1], fileInfo[2], proj = TRUE, name = name),
'setwd(oldwd) \n')
# If download was successful, the user is notified
writeLines(loadString, file.path(.libPaths(), 'kokua', 'data', paste0(name, '.R')))
message('Loading and reprojecting ', name, '...')
data(list = name)
message(name, ' reprojected to the following coordinate reference system: +proj=utm +zone=4 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0')
message('Successfully loaded ', name, '. Downloaded data may be viewed by running: plot(', name,')')
message('')
return(name)
}
.readSelect <- function(file, ext) { # Finds and returns target filename and file extension
switch(ext,
'bil' = c(file, ext),
'shp' = c(file, ext)
)
}
.scriptSelect <- function(file, ext, proj = FALSE, name = NULL) {
if (proj == FALSE) {
switch(ext,
'bil' = paste0("raster('", file, "')"),
'shp' = paste0("readOGR('.', '", gsub(paste0(name, '.', ext), '', file), "')")
# 'tif' =
# 'kml' =
# support for addtional extensions to be added
)
} else {
switch(ext,
# 'bil' = paste0('projectRaster(', name, ', crs = CRS("', '+proj=utm +zone=4 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0', '"))'),
'bil' = paste0('crs(', name, ') <- "+proj=utm +zone=4 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0"'),
'shp' = paste0(name, ' <- spTransform(', name,', CRS("', '+proj=utm +zone=4 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0', '"))')
# 'tif' =
# 'kml' =
# support for addtional extensions to be added
)
}
}
.fileExt <- function(path) { # Retrieves the file extension of a string
pos <- regexpr('\\.([[:alnum:]]+)$', path)
ifelse(pos > -1L, substring(path, pos + 1L), '')
}
getLoaded <- function(data = NULL, exact = FALSE) { # Retrieves names of loaded data or optionally queries through the list of loaded data
loaded <- list.dirs(path = file.path(.libPaths(), 'kokua', 'data'), full.names = FALSE, recursive = FALSE)
if (is.null(data)) {
results <- loaded[loaded != ""]
} else if (exact == TRUE) {
results <- loaded[which(loaded == data)]
} else {
results <- grep(data, loaded, value = TRUE)
}
if (identical(results, character(0))) {
return(NULL)
}
return(results)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.