Merge pull request #66 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.3.5.9000
+Version: 0.4.0
 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,

NAMESPACE

@@ -3,10 +3,10 @@
 export(AddClusterButton)
 export(AddColorKey)
 export(AddGradientLegend)
+export(AddHomeButton)
 export(AddInsetMap)
 export(AddLegend)
 export(AddPoints)
-export(AddRefreshButton)
 export(AddScaleBar)
 export(AddSearchButton)
 export(BumpDisconnectCells)
@@ -19,6 +19,7 @@ export(ExtractAlongTransect)
 export(FindOptimalSubset)
 export(FormatPval)
 export(GetDaysInMonth)
+export(GetTolColors)
 export(Grid2Polygons)
 export(IsPackageInstalled)
 export(POSIXct2Character)

NEWS.md

@@ -1,4 +1,6 @@
-# inlmisc 0.3.5.9000
+# inlmisc 0.4.0
+
+- Add `GetTolColors` function, used to access color palettes by Paul Tol.
 
 - Avoid importing all functions from a package.
 
@@ -29,7 +31,7 @@
 
 - In `CreateWebMap` function, remove coordinates and zoom level information from top of map.
 
-- Add `AddRefreshButton`, `AddClusterButton`, and `AddSearchButton`, and `AddLegend` functions,
+- Add `AddHomeButton`, `AddClusterButton`, and `AddSearchButton`, and `AddLegend` functions,
   used to add additional web map elements.
 
 - In `FindOptimalSubset` function, allow integer chromosomes to be specified for the `suggestions` argument.

R/AddGradientLegend.R

@@ -49,7 +49,7 @@
 #'                   scientific = TRUE, strip.dim = c(1, 14))
 #'
 
-AddGradientLegend <- function(breaks, pal, at=NULL, n=5L, labels=TRUE,
+AddGradientLegend <- function(breaks, pal, at=NULL, n=5, labels=TRUE,
                               scientific=FALSE, title=NULL,
                               loc=c("bottomleft", "topleft", "topright", "bottomright"),
                               inset=0, strip.dim=c(2, 8)) {

R/AddPoints.R

@@ -401,7 +401,7 @@ AddPoints <- function(x, y=NULL, z=NULL, zcol=1, crs=NULL,
 
 ##
 
-.Map2Color <- function(x, Pal, xlim=NULL, n=100L){
+.Map2Color <- function(x, Pal, xlim=NULL, n=100L) {
   if (length(x) == 0) return(NULL)
   if (is.null(xlim)) xlim <- range(x)
   Pal(n)[findInterval(x, seq(xlim[1], xlim[2], length.out=n), all.inside=TRUE)]

R/AddWebMapElements.R

@@ -1,8 +1,8 @@
 #' Add Miscellaneous Web Map Elements
 #'
 #' These functions can be used to augment a \href{http://leafletjs.com/}{Leaflet} web map with additional elements.
-#' The \code{AddRefreshButton} function adds a button that sets the map view to the original extent.
-#' The \code{AddClusterButton} function adds a button that toggles marker clusters between frozen and unfrozen states.
+#' The \code{AddHomeButton} function adds a button that zooms to the initial map extent.
+#' The \code{AddClusterButton} function adds a button that toggles marker clusters on and off.
 #' The \code{AddSearchButton} function adds a search element that may be used to locate, and move to, a marker.
 #' And the \code{AddCircleLegend} function adds a map legend.
 #'
@@ -60,7 +60,7 @@
 #' map <- CreateWebMap("Topo")
 #' map <- leaflet::addMarkers(map, label = ~name, popup = ~name, clusterOptions = opt,
 #'                            clusterId = "cluster", group = "marker", data = spdf)
-#' map <- AddRefreshButton(map)
+#' map <- AddHomeButton(map)
 #' map <- AddClusterButton(map, clusterId = "cluster")
 #' map <- AddSearchButton(map, group = "marker", zoom = 15,
 #'                        textPlaceholder = "Search city names...")
@@ -83,7 +83,7 @@ NULL
 #' @rdname AddWebMapElements
 #' @export
 
-AddRefreshButton <- function(map, extent=NULL, position="topleft") {
+AddHomeButton <- function(map, extent=NULL, position="topleft") {
 
   # check arguments
   checkmate::assertClass(map, c("leaflet", "htmlwidget"))
@@ -99,8 +99,8 @@ AddRefreshButton <- function(map, extent=NULL, position="topleft") {
   js <- sprintf("function(btn, map) {
                    map.fitBounds([[%f, %f],[%f, %f]]);
                  }", e[3], e[1], e[4], e[2])
-  button <- leaflet::easyButton(icon="fa-refresh",
-                                title="Refresh view",
+  button <- leaflet::easyButton(icon="fa-home fa-lg",
+                                title="Zoom to initial map extent",
                                 onClick=htmlwidgets::JS(js),
                                 position=position)
 
@@ -122,26 +122,26 @@ AddClusterButton <- function(map, clusterId, position="topleft") {
   # Javascript derived from https://rstudio.github.io/leaflet/morefeatures.html
   # accessed on 2017-11-06.
 
-  # unfrozen state
+  # disable clusters
   js <- sprintf("function(btn, map) {
                    var clusterManager = map.layerManager.getLayer('cluster', '%s');
-                   clusterManager.freezeAtZoom();
-                   btn.state('frozen-markers');
+                   clusterManager.disableClustering();
+                   btn.state('disable-cluster');
                  }", clusterId)
-  s0 <- leaflet::easyButtonState(stateName="unfrozen-markers",
-                                 icon="fa-circle-o",
-                                 title="Freeze clusters",
+  s0 <- leaflet::easyButtonState(stateName="enable-cluster",
+                                 icon="fa-circle",
+                                 title="Disable clustering",
                                  onClick=htmlwidgets::JS(js))
 
-  # frozen state
+  # enable clusters
   js <- sprintf("function(btn, map) {
                    var clusterManager = map.layerManager.getLayer('cluster', '%s');
-                   clusterManager.unfreeze();
-                   btn.state('unfrozen-markers');
+                   clusterManager.enableClustering();
+                   btn.state('enable-cluster');
                  }", clusterId)
-  s1 <- leaflet::easyButtonState(stateName="frozen-markers",
-                                 icon="fa-circle",
-                                 title="Unfreeze clusters",
+  s1 <- leaflet::easyButtonState(stateName="disable-cluster",
+                                 icon="fa-circle-o",
+                                 title="Enable clustering",
                                  onClick=htmlwidgets::JS(js))
 
   # create button
@@ -182,11 +182,12 @@ AddSearchButton <- function(map, group, propertyName="label", zoom=NULL,
 
 .SearchDependencies <- function() {
   src <- system.file("htmlwidgets/plugins/leaflet-search", package="inlmisc")
+  css <- if (utils::packageVersion("leaflet") < 2) "leaflet-search-old.css" else "leaflet-search.css"
   list(htmltools::htmlDependency(name="leaflet-search",
-                                 version="2.3.7",
+                                 version="2.4.0",
                                  src=src,
                                  script=c("leaflet-search.min.js", "leaflet-search-binding.js"),
-                                 stylesheet="leaflet-search.min.css"))
+                                 stylesheet=css))
 }
 
 

R/ExportRasterStack.R

@@ -24,7 +24,7 @@
 #'   Therefore, the conversion of gridded data between cartographic projections may introduce a new source of error.
 #'
 #'   To install \file{zip.exe} on windows, download the latest binary version from the
-#'   \href{http://www.info-zip.org/Zip.html#Downloads}{Info-ZIP} website;
+#'   \href{https://www.7-zip.org/download.html}{Info-ZIP} website;
 #'   select one of the given FTP locations, enter directory \file{win32}, download \file{zip300xn.zip}, and extract.
 #'
 #' @return Used for the side-effect files written to disk.

R/ExtractAlongTransect.R

@@ -150,9 +150,8 @@ ExtractAlongTransect <- function(transect, r) {
     v.d <- c(v.d, dist.along.transect[i, i + 1L])
   }
 
-  FUN <- function(s) {
+  return(lapply(segs, function(s) {
     sp::SpatialPointsDataFrame(s[, 1:2], data.frame(s[, -(1:2)], row.names=NULL),
                                proj4string=crs, match.ID=FALSE)
-  }
-  return(lapply(segs, FUN))
+  }))
 }

R/FindOptimalSubset.R

@@ -117,9 +117,9 @@
 #' }
 #'
 
-FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100L,
-                              migrationRate=0.1, migrationInterval=10L,
-                              pcrossover=0.8, pmutation=0.1, elitism=0L,
+FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100,
+                              migrationRate=0.1, migrationInterval=10,
+                              pcrossover=0.8, pmutation=0.1, elitism=0,
                               maxiter=1000L, run=maxiter, suggestions=NULL,
                               parallel=TRUE, seed=NULL) {
 
@@ -159,8 +159,10 @@ FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100L,
         set.seed(seed); m <- t(apply(m, 1, sample, size=k))
       } else if (k > ncol(m)) {
         idxs <- seq_len(n)
-        FUN <- function(i) c(i, sample(idxs[-i], k - ncol(m)))
-        set.seed(seed); m <- t(apply(m, 1, FUN))
+        set.seed(seed)
+        m <- t(apply(m, 1, function(i) {
+          c(i, sample(idxs[-i], k - ncol(m)))
+        }))
       }
       suggestions <- t(apply(m, 1, function(i) EncodeChromosome(i, n)))
     }
@@ -197,8 +199,9 @@ FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100L,
   })
 
   # decode solution
-  FUN <- function(i) sort(DecodeChromosome(i, n))
-  m <- t(apply(ga_output@solution, 1, FUN))
+  m <- t(apply(ga_output@solution, 1, function(i) {
+    sort(DecodeChromosome(i, n))
+  }))
   solution <- m[!duplicated(m), , drop=FALSE]
 
   # bundle output
@@ -237,8 +240,9 @@ FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100L,
 .Crossover <- function(object, parents, n) {
   fitness_parents <- object@fitness[parents]
   encoded_parents <- object@population[parents, , drop=FALSE]
-  FUN <- function(i) DecodeChromosome(i, n)
-  decoded_parents <- t(apply(encoded_parents, 1, FUN))
+  decoded_parents <- t(apply(encoded_parents, 1, function(i) {
+    DecodeChromosome(i, n)
+  }))
   p1 <- decoded_parents[1, ]
   p2 <- decoded_parents[2, ]
   c1 <- p1
@@ -249,8 +253,9 @@ FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100L,
   c1[i1] <- p2[i1]
   c2[i2] <- p1[i2]
   decoded_children <- rbind(c1, c2)
-  FUN <- function(i) EncodeChromosome(i, n)
-  encoded_children <- t(apply(decoded_children, 1, FUN))
+  encoded_children <- t(apply(decoded_children, 1, function(i) {
+    EncodeChromosome(i, n)
+  }))
   m <- t(apply(object@population, 1, function(i) sort(DecodeChromosome(i, n))))
   FindFitness <- function(child) {
     return(object@fitness[which(apply(m, 1, function(i) identical(i, child)))[1]])
@@ -297,15 +302,17 @@ FindOptimalSubset <- function(n, k, Fitness, ..., popSize=100L,
 
 EncodeChromosome <- function(x, n) {
   width <- ceiling(log2(n + 1))
-  FUN <- function(i) GA::decimal2binary(i, width)
-  return(unlist(lapply(x, FUN)))
+  return(unlist(lapply(x, function(i) {
+    GA::decimal2binary(i, width)
+  })))
 }
 
 #' @rdname EncodeChromosome
 #' @export
 
 DecodeChromosome <- function(y, n) {
   width <- ceiling(log2(n + 1))
-  FUN <- function(i) GA::binary2decimal(y[i:(i + width - 1L)])
-  return(vapply(seq(1, length(y), by=width), FUN, 0))
+  return(vapply(seq(1, length(y), by=width), function(i) {
+    GA::binary2decimal(y[i:(i + width - 1L)])
+  }, 0))
 }

R/GetTolColors.R

@@ -0,0 +1,72 @@
+#' Color Palette for Qualitative Data
+#'
+#' This function creates a vector of \code{n} contiguous colors from color schemes by Paul Tol (2012).
+#'
+#' @param n 'integer'.
+#'   Number of colors to be in the palette, the maximum is 21.
+#' @param alpha 'numeric'.
+#'   Alpha transparency, parameter values range from 0 (fully transparent) to 1 (fully opaque).
+#'   Specify as \code{NULL} to exclude the alpha channel color component.
+#' @param plot 'logical'.
+#'   Whether to display the color palette.
+#'
+#' @return Returns a 'character' vector of length \code{n} with elements of 7 or 9 characters,
+#'   "#" followed by the red, blue, green, and optionally alpha values in hexadecimal.
+#'
+#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
+#'
+#' @references
+#'   Tol, Paul, 2012, Colour Schemes:
+#'   SRON Technical Note, doc. no. SRON/EPS/TN/09-002, issue 2.2, 16 p.,
+#'   accesed January 26, 2018 at \url{https://personal.sron.nl/~pault/colourschemes.pdf}.
+#'
+#' @keywords color
+#'
+#' @export
+#'
+#' @examples
+#' GetTolColors(7, plot = TRUE)
+#'
+#' GetTolColors(21, alpha = 0.85, plot = TRUE)
+#'
+
+GetTolColors <- function(n, alpha=1, plot=FALSE) {
+
+  checkmate::assertInt(n, lower=1, upper=21)
+  checkmate::assertNumber(alpha, lower=0, upper=1, finite=TRUE, null.ok=TRUE)
+  checkmate::assertFlag(plot)
+
+  # color schemes copied from Peter Carl's blog post, accessed January 26, 2018 at
+  # https://tradeblotter.wordpress.com/2013/02/28/the-paul-tol-21-color-salute/
+  pal <- list(c("#4477AA"),
+              c("#4477AA", "#CC6677"),
+              c("#4477AA", "#DDCC77", "#CC6677"),
+              c("#4477AA", "#117733", "#DDCC77", "#CC6677"),
+              c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677"),
+              c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677", "#AA4499"),
+              c("#332288", "#88CCEE", "#44AA99", "#117733", "#DDCC77", "#CC6677", "#AA4499"),
+              c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#CC6677", "#AA4499"),
+              c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#CC6677", "#882255", "#AA4499"),
+              c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#661100", "#CC6677", "#882255", "#AA4499"),
+              c("#332288", "#6699CC", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#661100", "#CC6677", "#882255", "#AA4499"),
+              c("#332288", "#6699CC", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#661100", "#CC6677", "#AA4466", "#882255", "#AA4499"),
+              c("#882E72", "#B178A6", "#D6C1DE", "#1965B0", "#5289C7", "#7BAFDE", "#4EB265", "#90C987", "#CAE0AB", "#F7EE55", "#F6C141", "#F1932D", "#E8601C"),
+              c("#882E72", "#B178A6", "#D6C1DE", "#1965B0", "#5289C7", "#7BAFDE", "#4EB265", "#90C987", "#CAE0AB", "#F7EE55", "#F6C141", "#F1932D", "#E8601C", "#DC050C"),
+              c("#114477", "#4477AA", "#77AADD", "#117755", "#44AA88", "#99CCBB", "#777711", "#AAAA44", "#DDDD77", "#771111", "#AA4444", "#DD7777", "#771144", "#AA4477", "#DD77AA"),
+              c("#771155", "#AA4488", "#CC99BB", "#114477", "#4477AA", "#77AADD", "#117777", "#44AAAA", "#77CCCC", "#777711", "#AAAA44", "#DDDD77", "#774411", "#AA7744", "#DDAA77", "#771122"),
+              c("#771155", "#AA4488", "#CC99BB", "#114477", "#4477AA", "#77AADD", "#117777", "#44AAAA", "#77CCCC", "#777711", "#AAAA44", "#DDDD77", "#774411", "#AA7744", "#DDAA77", "#771122", "#AA4455"),
+              c("#771155", "#AA4488", "#CC99BB", "#114477", "#4477AA", "#77AADD", "#117777", "#44AAAA", "#77CCCC", "#777711", "#AAAA44", "#DDDD77", "#774411", "#AA7744", "#DDAA77", "#771122", "#AA4455", "#DD7788"),
+              c("#771155", "#AA4488", "#CC99BB", "#114477", "#4477AA", "#77AADD", "#117777", "#44AAAA", "#77CCCC", "#117744", "#44AA77", "#88CCAA", "#777711", "#AAAA44", "#DDDD77", "#774411", "#AA7744", "#DDAA77", "#771122"),
+              c("#771155", "#AA4488", "#CC99BB", "#114477", "#4477AA", "#77AADD", "#117777", "#44AAAA", "#77CCCC", "#117744", "#44AA77", "#88CCAA", "#777711", "#AAAA44", "#DDDD77", "#774411", "#AA7744", "#DDAA77", "#771122", "#AA4455"),
+              c("#771155", "#AA4488", "#CC99BB", "#114477", "#4477AA", "#77AADD", "#117777", "#44AAAA", "#77CCCC", "#117744", "#44AA77", "#88CCAA", "#777711", "#AAAA44", "#DDDD77", "#774411", "#AA7744", "#DDAA77", "#771122", "#AA4455", "#DD7788"))
+  col <- pal[[n]]
+
+  if (is.finite(alpha)) col <- grDevices::adjustcolor(col, alpha.f=alpha)
+
+  if (plot) {
+    graphics::plot.default(0, 0, type="n", xlim=c(0, 1), ylim=c(0, 1), axes=FALSE, xlab="", ylab="")
+    graphics::rect(0:(n - 1) / n, 0, 1:n / n, 1, col=col, border="#D3D3D3")
+  }
+
+  return(col)
+}