Merge pull request #95 from jfisher-usgs/master

Merge with upstream

Author: jfisher-usgs

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: inlmisc
 Title: Miscellaneous Functions for the USGS INL Project Office
-Version: 0.4.3.9000
+Version: 0.4.4
 Authors@R: person(given=c("Jason", "C."), family="Fisher", role=c("aut", "cre"), email="jfisher@usgs.gov", comment=c(ORCID="0000-0001-9032-8912"))
 Description: A collection of functions for creating high-level graphics,
     performing raster-based analysis, processing MODFLOW-based models,
@@ -12,7 +12,7 @@ Depends:
     R (>= 3.4.0)
 Imports:
     checkmate,
-    dplyr,
+    data.table,
     GA,
     graphics,
     grDevices,

Makefile

@@ -7,8 +7,8 @@ PKGSRC  := $(shell basename `pwd`)
 all: docs install check
 
 docs:
-	R -q -e 'devtools::document()';\
-	R -q -e 'devtools::clean_dll()';\
+	R -q -e 'Rd2roxygen::roxygen_and_build('\''.'\'', build=FALSE, reformat=FALSE)';\
+	R -q -e 'pkgbuild::clean_dll()';\
 
 build:
 	cd ..;\

NAMESPACE

@@ -11,6 +11,7 @@ export(AddNorthArrow)
 export(AddPoints)
 export(AddScaleBar)
 export(AddSearchButton)
+export(BuildVignettes)
 export(BumpDisconnectCells)
 export(BumpRiverStage)
 export(CreateWebMap)
@@ -44,5 +45,6 @@ export(SetPolygons)
 export(SummariseBudget)
 export(ToScientific)
 import(rgdal)
+importFrom(data.table,data.table)
 importFrom(igraph,clusters)
 useDynLib(inlmisc, .registration=TRUE, .fixes="C_")

NEWS.md

@@ -1,4 +1,10 @@
-# inlmisc 0.4.3.9000
+# inlmisc 0.4.4
+
+- Add `BuildVignettes` function, used to build package vignettes.
+
+- In `SummariseBudget` function, improve memory management.
+
+- Change package imports by adding **data.table** and removing **dplyr**.
 
 - Add `SetHinge` function, used to specify a hinge location in a color palette.
 

R/BuildVignettes.R

@@ -0,0 +1,53 @@
+#' Build Package Vignettes
+#'
+#' Build package vignettes from their sources and place in the \code{/inst/doc} folder.
+#'
+#' @param pkg 'character' string.
+#'   Package path, by default the \link[=getwd]{working directory}.
+#' @param quiet 'logical' flag.
+#'   Whether to supress most output.
+#' @param clean 'logical' flag.
+#'   Whether to remove all intermediate files generated by the build.
+#' @param gs_quality 'character' string.
+#'   Quality of compacted PDF files,
+#'   see \code{\link[tools]{compactPDF}} function for details.
+#'
+#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
+#'
+#' @seealso \code{\link[tools]{buildVignettes}}
+#'
+#' @keywords utilities
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' BuildVignettes("<path/to/package>", gs_quality = "ebook")
+#' }
+#'
+
+BuildVignettes <- function(pkg=".", quiet=TRUE, clean=TRUE, gs_quality=NULL) {
+
+  checkmate::assertFileExists(file.path(pkg, "DESCRIPTION"))
+  checkmate::assertFlag(quiet)
+  checkmate::assertFlag(clean)
+  if (!is.null(gs_quality))
+    gs_quality <- match.arg(gs_quality, c("none", "printer", "ebook", "screen"))
+
+  tools::buildVignettes(dir=pkg, quiet=quiet, clean=clean, tangle=TRUE)
+
+  v <- tools::pkgVignettes(dir=pkg, output=TRUE, source=TRUE)
+  if (length(v) == 0) return(invisible(NULL))
+  out <- c(v$outputs, unique(unlist(v$sources, use.names=FALSE)))
+
+  doc <- file.path(pkg, "inst/doc")
+
+  dir.create(doc, showWarnings=!quiet, recursive=TRUE)
+  file.copy(c(v$docs, out), doc, overwrite=TRUE)
+  file.remove(out)
+
+  if (!is.null(gs_quality))
+    tools::compactPDF(paths=doc, gs_quality=gs_quality)
+
+  invisible(TRUE)
+}

R/ExportRasterStack.R

@@ -60,20 +60,20 @@ ExportRasterStack <- function(rs, path, zip="", col=NULL) {
 
   # check arguments
   stopifnot(inherits(rs, c("RasterStack", "RasterBrick")))
-  checkmate::assertDirectoryExists(path)
+  checkmate::assertString(path)
   checkmate::assertString(zip)
   if (zip != "") checkmate::assertFileExists(zip)
   checkmate::assertCharacter(col, null.ok=TRUE)
 
-  if (is.null(col)) col <- GetColors(255, stops=c(0.3, 0.9))
-
   dir.create(path, showWarnings=FALSE, recursive=TRUE)
   dir.create(path.csv <- file.path(path, "csv"), showWarnings=FALSE)
   dir.create(path.png <- file.path(path, "png"), showWarnings=FALSE)
   dir.create(path.tif <- file.path(path, "tif"), showWarnings=FALSE)
   dir.create(path.rda <- file.path(path, "rda"), showWarnings=FALSE)
   dir.create(path.kml <- file.path(path, "kml"), showWarnings=FALSE)
 
+  if (is.null(col)) col <- GetColors(255, stops=c(0.3, 0.9))
+
   n <- 0L
   for (i in names(rs)) {
     n <- n + 1L

R/GetColors.R

@@ -92,7 +92,12 @@
 #'   Generic Mapping Tools: Improved version released, AGU, v. 94, no. 45, p. 409--410
 #'   doi:\href{https://doi.org/10.1002/2013EO450001}{10.1002/2013EO450001}
 #'
-#' @seealso \code{\link{SetHinge}}, \code{\link[grDevices]{col2rgb}}
+#' @seealso
+#'   \code{\link{SetHinge}} function to set the hinge location in
+#'   a color palette derived from one or two color schemes.
+#'
+#'   \code{\link[grDevices]{col2rgb}} function to express palette
+#'   colors represented in the hexadecimal format as RGB triplets (R, G, B).
 #'
 #' @keywords color
 #'

R/ReadCodeChunks.R

@@ -25,6 +25,7 @@
 #' @export
 #'
 #' @examples
+#' \dontrun{
 #' file <- system.file("misc", "knitr-markdown.Rmd", package = "inlmisc")
 #' chunks <- ReadCodeChunks(file)
 #'
@@ -33,6 +34,7 @@
 #' chunks[["named-chunk-2"]]
 #'
 #' eval(parse(text = unlist(chunks[c("unnamed-chunk-3", "named-chunk-4")])))
+#' }
 #'
 
 ReadCodeChunks <- function(path) {

R/ReadModflowBinary.R

@@ -67,9 +67,9 @@ ReadModflowBinary <- function(path, data.type=c("array", "flow"),
   endian <- match.arg(endian)
   checkmate::assertFlag(rm.totim.0)
 
-  ans <- try(.ReadBinary(path, data.type, endian, nbytes=4), silent=TRUE)
+  ans <- try(.ReadBinary(path, data.type, endian, nbytes=4L), silent=TRUE)
   if (inherits(ans, "try-error"))
-    ans <- .ReadBinary(path, data.type, endian, nbytes=8)
+    ans <- .ReadBinary(path, data.type, endian, nbytes=8L)
   if (rm.totim.0)
     ans <- ans[vapply(ans, function(i) i$totim, 0) != 0]
   ans
@@ -81,7 +81,7 @@ ReadModflowBinary <- function(path, data.type=c("array", "flow"),
   checkmate::assertFileExists(path)
   checkmate::assertString(data.type)
   checkmate::assertString(endian)
-  stopifnot(nbytes %in% c(4, 8))
+  stopifnot(nbytes %in% c(4L, 8L))
 
   con <- file(path, open="rb", encoding="bytes")
   on.exit(close(con, type="rb"))
@@ -136,33 +136,33 @@ ReadModflowBinary <- function(path, data.type=c("array", "flow"),
                     "wells")
   lst <- list()
   repeat {
-    kstp <- readBin(con, "integer", n=1, size=4, endian=endian)
+    kstp <- readBin(con, "integer", n=1L, size=4L, endian=endian)
     if (length(kstp) == 0) break
-    kper <- readBin(con, "integer", n=1, size=4, endian=endian)
+    kper <- readBin(con, "integer", n=1L, size=4L, endian=endian)
 
     if (data.type == "array") {
-      pertim <- readBin(con, "numeric", n=1, size=nbytes, endian=endian)
-      totim  <- readBin(con, "numeric", n=1, size=nbytes, endian=endian)
-      desc   <- readBin(readBin(con, "raw", n=16, size=1, endian=endian),
-                        "character", n=1, endian=endian)
+      pertim <- readBin(con, "numeric", n=1L, size=nbytes, endian=endian)
+      totim  <- readBin(con, "numeric", n=1L, size=nbytes, endian=endian)
+      desc   <- readBin(readBin(con, "raw", n=16L, size=1L, endian=endian),
+                        "character", n=1L, endian=endian)
       desc <- .TidyDescription(desc)
       if (!desc %in% valid.desc) break
-      ncol  <- readBin(con, "integer", n=1, size=4, endian=endian)
-      nrow  <- readBin(con, "integer", n=1, size=4, endian=endian)
-      layer <- readBin(con, "integer", n=1, size=4, endian=endian)
+      ncol  <- readBin(con, "integer", n=1L, size=4L, endian=endian)
+      nrow  <- readBin(con, "integer", n=1L, size=4L, endian=endian)
+      layer <- readBin(con, "integer", n=1L, size=4L, endian=endian)
       v     <- readBin(con, "numeric", n=nrow * ncol, size=nbytes, endian=endian)
       d <- matrix(v, nrow=nrow, ncol=ncol, byrow=TRUE)
       lst[[length(lst) + 1]] <- list(d=d, kstp=kstp, kper=kper, desc=desc,
                                      layer=layer, pertim=pertim, totim=totim)
 
     } else if (data.type == "flow") {
-      desc <- readBin(readBin(con, "raw", n=16, size=1, endian=endian),
-                      "character", n=1, endian=endian)
+      desc <- readBin(readBin(con, "raw", n=16L, size=1L, endian=endian),
+                      "character", n=1L, endian=endian)
       desc <- .TidyDescription(desc)
       if (!desc %in% valid.desc) break
-      ncol <- readBin(con, "integer", n=1, size=4, endian=endian)
-      nrow <- readBin(con, "integer", n=1, size=4, endian=endian)
-      nlay <- readBin(con, "integer", n=1, size=4, endian=endian)
+      ncol <- readBin(con, "integer", n=1L, size=4L, endian=endian)
+      nrow <- readBin(con, "integer", n=1L, size=4L, endian=endian)
+      nlay <- readBin(con, "integer", n=1L, size=4L, endian=endian)
 
       if (nlay > 0) {
         x <- .Read3dArray(con, nrow, ncol, nlay, nbytes, endian)
@@ -173,73 +173,77 @@ ReadModflowBinary <- function(path, data.type=c("array", "flow"),
 
       } else {  # compact form is used
         nlay <- abs(nlay)
-        itype  <- readBin(con, "integer", n=1, size=4, endian=endian)
-        delt   <- readBin(con, "numeric", n=1, size=nbytes, endian=endian)
-        pertim <- readBin(con, "numeric", n=1, size=nbytes, endian=endian)
-        totim  <- readBin(con, "numeric", n=1, size=nbytes, endian=endian)
+        itype  <- readBin(con, "integer", n=1L, size=4L, endian=endian)
+        delt   <- readBin(con, "numeric", n=1L, size=nbytes, endian=endian)
+        pertim <- readBin(con, "numeric", n=1L, size=nbytes, endian=endian)
+        totim  <- readBin(con, "numeric", n=1L, size=nbytes, endian=endian)
 
-        if (itype == 5)
-          nval <- readBin(con, "integer", n=1, size=4, endian=endian)
+        if (itype == 5L)
+          nval <- readBin(con, "integer", n=1L, size=4L, endian=endian)
         else
           nval <- 1L
         if (nval > 100) stop("more than one-hundred varaiables for each cell")
         if (nval > 1) {
-          ctmp <- readBin(readBin(con, "raw", n=16, size=1, endian=endian),
-                          "character", n=nval - 1, endian=endian)
+          ctmp <- readBin(readBin(con, "raw", n=16L, size=1L, endian=endian),
+                          "character", n=nval - 1L, endian=endian)
           ctmp <- .TidyDescription(ctmp)
         } else {
           ctmp <- NULL
         }
 
-        if (itype %in% c(0, 1)) {
-          nvalues <- ncol * nrow * nlay
+        if (itype %in% c(0L, 1L)) {
           d <- .Read3dArray(con, nrow, ncol, nlay, nbytes, endian)
           for (i in seq_along(d)) {
             lst[[length(lst) + 1]] <- list(d=d[[i]], kstp=kstp, kper=kper,
                                            desc=desc, layer=i, delt=delt,
                                            pertim=pertim, totim=totim)
           }
 
-        } else if (itype %in% c(2, 5)) {
-            nlist <- readBin(con, "integer", n=1, size=4, endian=endian)
+        } else if (itype %in% c(2L, 5L)) {
+            nlist <- readBin(con, "integer", n=1L, size=4L, endian=endian)
             if (nlist > (nrow * ncol * nlay))
               stop("large number of cells for which values will be stored")
             if (nlist > 0) {
-              d <- matrix(0, nrow=nlist, ncol=nval + 4)
+              d <- matrix(0, nrow=nlist, ncol=nval + 4L)
               colnames(d) <- make.names(c("icell", "layer", "row", "column", "flow", ctmp),
                                         unique=TRUE)
               for (i in seq_len(nlist)) {
-                d[i, 1] <- readBin(con, "integer", n=1, size=4, endian=endian)
+                d[i, 1] <- readBin(con, "integer", n=1L, size=4L, endian=endian)
                 d[i, seq_len(nval) + 4] <- readBin(con, "numeric", n=nval,
                                                    size=nbytes, endian=endian)
               }
               nrc <- nrow * ncol
-              d[, "layer"] <- as.integer((d[, "icell"] - 1) / nrc + 1)
-              d[, "row"]  <- as.integer(((d[, "icell"] - (d[, "layer"] - 1) * nrc) - 1) / ncol + 1)
-              d[, "column"] <- as.integer(d[, "icell"] - (d[, "layer"] - 1) * nrc - (d[, "row"] - 1) * ncol)
+              d[, "layer"] <- as.integer((d[, "icell"] - 1L) / nrc + 1L)
+              d[, "row"]  <- as.integer(((d[, "icell"] - (d[, "layer"] - 1L) * nrc)
+                                         - 1L) / ncol + 1L)
+              d[, "column"] <- as.integer(d[, "icell"] - (d[, "layer"] - 1L)
+                                          * nrc - (d[, "row"] - 1L) * ncol)
               lst[[length(lst) + 1]] <- list(d=d, kstp=kstp, kper=kper, desc=desc,
                                              delt=delt, pertim=pertim, totim=totim)
             }
 
-        } else if (itype == 3) {
-          layers <- readBin(con, "integer", n=nrow * ncol, size=4, endian=endian)
+        } else if (itype == 3L) {
+          layers <- readBin(con, "integer", n=nrow * ncol, size=4L, endian=endian)
           values <- readBin(con, "numeric", n=nrow * ncol, size=nbytes, endian=endian)
           for (i in sort(unique(layers))) {
             v <- values[layers == i]
             d <- matrix(v, nrow=nrow, ncol=ncol, byrow=TRUE)
             lst[[length(lst) + 1]] <- list(d=d, kstp=kstp, kper=kper, desc=desc,
-                                           layer=i, delt=delt, pertim=pertim, totim=totim)
+                                           layer=i, delt=delt, pertim=pertim,
+                                           totim=totim)
           }
 
-        } else if (itype == 4) {
+        } else if (itype == 4L) {
           v <- readBin(con, "numeric", n=nrow * ncol, size=nbytes, endian=endian)
           d <- matrix(v, nrow=nrow, ncol=ncol, byrow=TRUE)
           lst[[length(lst) + 1]] <- list(d=d, kstp=kstp, kper=kper, desc=desc,
-                                         layer=1, delt=delt, pertim=pertim, totim=totim)
+                                         layer=1L, delt=delt, pertim=pertim,
+                                         totim=totim)
           d[, ] <- 0
           for (i in seq_len(nlay)[-1]) {
             lst[[length(lst) + 1]] <- list(d=d, kstp=kstp, kper=kper, desc=desc,
-                                           layer=i, delt=delt, pertim=pertim, totim=totim)
+                                           layer=i, delt=delt, pertim=pertim,
+                                           totim=totim)
           }
 
         } else {

R/SetHinge.R

@@ -3,14 +3,14 @@
 #' The \emph{hinge} indicates a dramatic color change in a palette
 #' that is typically located at the midpoint of the data range.
 #' An asymmetrical data range can result in an undesired hinge location,
-#' where the location does not necessarily coincide with the break-point in the user's data.
-#' This function is used to specify a hinge location that is appropriate for your data.
+#' a location that does not necessarily coincide with the break-point in the user's data.
+#' This function can be used to specify a hinge location that is appropriate for your data.
 #'
 #' @param x 'numeric' object that can be passed to the \code{\link{range}}
 #'   function with \code{NA}'s removed.
-#'   That is, the user's data range (such as, at sea-level).
+#'   The user's data range.
 #' @param hinge 'numeric' number.
-#'   Hinge value in data units.
+#'   Hinge value (such as, at sea-level) in data units.
 #' @param scheme 'character' vector of length 1 or 2, value is recycled as necessary.
 #'   Name of color scheme(s).
 #'   The color palette is derived from one or two color schemes.
@@ -29,7 +29,7 @@
 #'   Values applied separately on either side of the hinge.
 #' @param stops 'numeric' vector of length 2.
 #'   Color stops defined by interval endpoints (between 0 and 1)
-#'   and used to select a subset of the color palette.
+#'   and used to select a subset of the color palette(s).
 #' @param allow_bias 'logical' flag.
 #'   Whether to allow bias in the color spacing.
 #'
@@ -181,7 +181,7 @@ SetHinge <- function(x, hinge, scheme="sunset", alpha=NULL, reverse=FALSE,
   s1 <- c(stp[1] + adj[1], ran - buf[1])
   s2 <- c(1 - ran + buf[2], 1 - stp[2] - adj[2])
 
-  if (s1[1] >= s1[2] | s2[1] >= s2[2])
+  if (s1[1] >= s1[2] || s2[1] >= s2[2])
     stop("problem with color stops and (or) buffer values")
 
   FUN <- function(...) {