migrate 'r-tools' functions to this package

moved useful stuff from https://github.com/achubaty/r-tools/
achubaty · Mar 15, 2017 · 2e5d62c · 2e5d62c
1 parent 9093e43
commit 2e5d62c
Show file tree

Hide file tree

Showing 33 changed files with 1,230 additions and 0 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -0,0 +1,2 @@
+^.*\.Rproj$
+^\.Rproj\.user$
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -0,0 +1,35 @@
+Package: amc
+Type: Package
+Title: Alex's Miscellaneous Code
+Version: 0.1.0
+Date: 2017-03-15
+Authors@R: c(
+    person(c("Alex", "M"), "Chubaty", email = "[email protected]",
+    role = c("aut", "cre", "cph")),
+    person(c("Eliot", "J", "B"), "McIntire", email = "[email protected]",
+    role = c("ctb")),
+    person(c("Josh"), "O'Brien", role = c("ctb"))
+    )
+Description: A collection of variously useful functions.
+Imports:
+  base64enc,
+  digest,
+  httr,
+  magrittr,
+  methods,
+  plyr,
+  raster,
+  rgdal,
+  sp,
+  utils
+Suggests:
+  knitr,
+  rmarkdown,
+  testthat
+BugReports: https://github.com/achubaty/amc/issues
+License: GPL-3
+ByteCompile: yes
+Encoding: UTF-8
+LazyData: true
+VignetteBuilder: knitr, rmarkdown
+RoxygenNote: 6.0.1
diff --git a/NAMESPACE b/NAMESPACE
@@ -0,0 +1,43 @@
+# Generated by roxygen2: do not edit by hand
+
+export(binstr)
+export(dl.data)
+export(fastMask)
+export(fastRasterize)
+export(geometric.mean)
+export(getOGR)
+export(get_deps)
+export(guesstimate)
+export(harmonic.mean)
+export(inRange)
+export(loadObjects)
+export(loadPackages)
+export(rmObjects)
+export(rndstr)
+export(saveObjects)
+export(source_github)
+export(sysmem)
+importFrom(base64enc,base64decode)
+importFrom(digest,digest)
+importFrom(httr,GET)
+importFrom(httr,add_headers)
+importFrom(httr,content)
+importFrom(httr,stop_for_status)
+importFrom(magrittr,"%>%")
+importFrom(methods,is)
+importFrom(plyr,mapvalues)
+importFrom(raster,brick)
+importFrom(raster,crop)
+importFrom(raster,extract)
+importFrom(raster,filename)
+importFrom(raster,getValues)
+importFrom(raster,nlayers)
+importFrom(raster,raster)
+importFrom(raster,stack)
+importFrom(rgdal,readOGR)
+importFrom(utils,download.file)
+importFrom(utils,install.packages)
+importFrom(utils,installed.packages)
+importFrom(utils,memory.limit)
+importFrom(utils,read.table)
+importFrom(utils,write.table)
diff --git a/R/binary-strings.R b/R/binary-strings.R
@@ -0,0 +1,40 @@
+#' Convert integer to binary string
+#'
+#' Description needed
+#'
+#' @param i         Positive integer <= 2^53 (<= 9.007199e+15).
+#'
+#' @param bits.max  Maximum number of bits to print (default \code{NA}).
+#'
+#' @return Character vector.
+#'
+#' @author Alex Chubaty
+#' @docType methods
+#' @export
+#' @rdname binstr
+#'
+#' @examples
+#' x <- sample(0:9999, 10000)
+#' y <- binstr(x) # length is 14 bits
+#'
+#' \dontrun{
+#' # alternate (but slower) conversion to binary string
+#' R.utils::intToBin(x)
+#' }
+#'
+#' # convert binary string to integer value (very fast)
+#' strtoi(y, base = 2)
+#' strtoi(substr(y, 1, 4), base = 2)
+#' strtoi(substr(y, 5, 8), base = 2)
+#' strtoi(substr(y, 9, 11), base = 2)
+#' strtoi(substr(y, 12, 14), base = 2)
+#'
+#' # see also `binary()` and `unbinary()` in the `composition` package (requires x11)
+#'
+binstr <- function(i, bits.max = NA) {
+    if (is.na(bits.max)) bits.max <- ceiling(log2(max(i)))
+
+    a <- 2 ^ ({bits.max - 1}:0)
+    b <- 2 * a
+    sapply(i, function(x) paste(as.integer((x %% b) >= a), collapse = ""))
+}
diff --git a/R/download-data.R b/R/download-data.R
@@ -0,0 +1,57 @@
+#' Intelligently download data
+#'
+#' Only downloads the specified files if it is not found locally.
+#' Optionally unzips the files.
+#'
+#' @param urls      A character vector of data file URLs.
+#' @param dest      The directory path in which data should be downloaded.
+#' @param checksum  Logical indicating whether downloaded files should be checksummed to verify them.
+#' @param unzip     Logical indicating whether the file should be unzipped after download.
+#'
+#' @author Alex Chubaty and Eliot Mcintire
+#' @docType methods
+#' @export
+#' @importFrom digest digest
+#' @importFrom utils download.file installed.packages read.table write.table
+#' @rdname dl.data
+#'
+dl.data <- function(urls, dest = ".", checksum = TRUE, unzip = FALSE) {
+  tmp <- lapply(urls, function(f) {
+    dest_file <- file.path(dest, basename(f))
+    checksum_file <- file.path(dest, paste0(sub("^([^.]*).*", "\\1", basename(f)), ".checksum"))
+    needDownload <- TRUE
+    if (file.exists(dest_file)) {
+      if (checksum) {
+        if (file.exists(checksum_file)) {
+          hash <- digest::digest(file = dest_file, algo = "xxhash64")
+          hashCheck <- read.table(checksum_file, stringsAsFactors = FALSE)
+          if (hash == hashCheck$checksum) {
+            needDownload <- FALSE
+            message("File ", basename(dest_file), " already exists. Skipping download.")
+          } else {
+            needDownload <- TRUE
+          }
+        } else {
+          message("No hash file exists. Assuming current file (", basename(f),") is correct.")
+          hash <- digest::digest(file = dest_file, algo = "xxhash64")
+          write.table(data.frame(filename = dest_file, checksum = hash),
+                      file = checksum_file)
+          needDownload <- FALSE
+        }
+      } else {
+        message(basename(dest_file), " already exists. Skipping download.")
+        needDownload <- FALSE
+      }
+    }
+
+    if (needDownload)  {
+      download.file(f, dest_file)
+      checksum <- digest::digest(file = dest_file, algo = "xxhash64")
+      write.table(data.frame(filename = dest_file, checksum = checksum),
+                  file = checksum_file)
+
+      if (unzip) { unzip(dest_file, exdir = dest, overwrite = TRUE) }
+    }
+  })
+  return(invisible())
+}
diff --git a/R/faster-rasters.R b/R/faster-rasters.R
@@ -0,0 +1,75 @@
+#' Faster masking of a raster using a polygon
+#'
+#' Description needed
+#'
+#' @note HAS NOT BEEN FULLY TESTED
+#'
+#' @param stack      A \code{RasterStack} object.
+#'
+#' @param polygon    A \code{SpatialPolygons} object.
+#'
+#' @return A \code{Raster*} object.
+#'
+#' @author Eliot Mcintire
+#' @docType methods
+#' @export
+#' @importFrom raster crop extract nlayers raster stack
+#' @rdname fastMask
+#'
+fastMask <- function(stack, polygon) {
+  croppedStack <- crop(stack, polygon)
+  nonNACellIDs <- extract(croppedStack[[1]], polygon, cellnumbers = TRUE)
+  nonNACellIDs <- do.call(rbind, nonNACellIDs)
+  singleRas <- raster(croppedStack[[1]])
+  singleRas[] <- NA
+  maskedStack <- stack(lapply(seq_len(nlayers(stack)), function(x) singleRas))
+  names(maskedStack) <- names(stack)
+  maskedStack[nonNACellIDs[, "cell"]] <- croppedStack[nonNACellIDs[, "cell"]]
+  maskedStack
+}
+
+#' Faster rasterizing of a polygon
+#'memory.limit
+#' Description needed.
+#'
+#' @note HAS NOT BEEN FULLY TESTED
+#'
+#' @param polygon    A \code{SpatialPolygons} object.
+#'
+#' @param ras        A \code{RasterLayer} object.
+#'
+#' @param field      The field to use from \code{polygon}.
+#'
+#' @return A \code{Raster*} object.
+#'
+#' @author Eliot Mcintire
+#' @docType methods
+#' @export
+#' @importFrom plyr mapvalues
+#' @importFrom raster extract raster
+#' @rdname fastRasterize
+#'
+fastRasterize <- function(polygon, ras, field) {
+  nonNACellIDs <- extract(ras, polygon, cellnumbers = TRUE)
+  polygonIDs <- seq_along(nonNACellIDs)
+  nonNACellIDs <- lapply(polygonIDs, function(x) cbind(nonNACellIDs[[x]], "ID" = x))
+  nonNACellIDs <- do.call(rbind, nonNACellIDs)
+  singleRas <- raster(ras)
+  singleRas[] <- NA
+  singleRas[nonNACellIDs[, "cell"]] <- nonNACellIDs[, "ID"]
+  if (!missing(field)) {
+    if (length(field) == 1) {
+      singleRas[] <- mapvalues(singleRas[], from = polygonIDs, to = polygon[[field]])
+      numFields <- 1
+    } else {
+      numFields <- 2
+    }
+  } else {
+    numFields <- 3
+  }
+  if (numFields == 3) {
+    field <- names(polygon)
+  }
+  levels(singleRas) <- data.frame(ID = polygonIDs, polygon[field])
+  singleRas
+}
diff --git a/R/getOGR.R b/R/getOGR.R
@@ -0,0 +1,24 @@
+#' \code{readOGR} from file not in the current working directory
+#'
+#' Simply a wrapper for `readOGR` that allows reading a file in a directory
+#' that is not the current working directory.
+#'
+#' @param layer  Layer name. See \code{\link[rgdal]{readOGR}}.
+#'
+#' @param path   Parent directory of the data source.
+#'
+#' @param ...    Other arguments passed to \code{readOGR}.
+#'
+#' @return A Spatial object.
+#'
+#' @author Alex Chubaty
+#' @docType methods
+#' @export
+#' @importFrom rgdal readOGR
+#' @rdname getOGR
+#'
+getOGR <- function(layer, path, ...) {
+  orig.dir <- getwd()
+  setwd(path); on.exit(setwd(orig.dir))
+  readOGR(dsn = ".", layer = layer, ...)
+}
diff --git a/R/get_deps.R b/R/get_deps.R
@@ -0,0 +1,24 @@
+#' Get package dependencies (offline)
+#'
+#' Read a package's dependencies from file, rather than searching CRAN.
+#' From \url{http://stackoverflow.com/a/30225680/1380598}.
+#'
+#' @param path  A local file path to a package directory.
+#'
+#' @return A list of package dependencies.
+#'
+#' @author Josh O'Brien
+#' @docType methods
+#' @export
+#' @rdname get_deps
+#'
+#' @examples
+#' get_deps(system.file(package = "amc"))
+#'
+get_deps <- function(path) {
+  dcf <- read.dcf(file.path(path, "DESCRIPTION"))
+  jj <- intersect(c("Depends", "Imports", "Suggests"), colnames(dcf))
+  val <- unlist(strsplit(dcf[, jj], ","), use.names = FALSE)
+  val <- gsub("\\s.*", "", trimws(val))
+  val[val != "R"]
+}
diff --git a/R/inRange.R b/R/inRange.R
@@ -0,0 +1,37 @@
+#' Test whether a number lies within range \code{[a,b]}
+#'
+#' Default values of \code{a=0; b=1} allow for quick test if
+#' \code{x} is a probability.
+#'
+#' @param x   values to be tested
+#' @param a   lower bound (default 0)
+#' @param b   upper bound (default 1)
+#'
+#' @return Logical vectors. \code{NA} values in \code{x} are retained.
+#'
+#' @author Alex Chubaty
+#' @docType methods
+#' @export
+#' @importFrom methods is
+#' @importFrom raster getValues
+#' @rdname inRange
+#'
+#' @examples
+#' set.seed(100)
+#' x <- stats::rnorm(4) ## -0.50219235  0.13153117 -0.07891709  0.88678481
+#' inRange(x, 0, 1)
+#'
+inRange <- function(x, a = 0, b = 1) {
+  if (is.null(x)) return(NULL) # is this desired behaviour?
+  if (!is.numeric(x)) {
+    if (is(x, "Raster")) {
+      x <- getValues(x)
+    } else {
+      stop("x must be numeric.")
+    }
+  }
+  if (!is.numeric(a) || !is.numeric(b)) stop("invalid (non-numeric) bounds.")
+  if (is.na(a) || is.na(b)) stop("invalid (NA) bounds.")
+  if (a >= b) stop("a cannot be greater than b.")
+  return((x - a) * (b - x) >= 0) # NAs will propagate -- is this desired?
+}