Skip to content

Commit

Permalink
Merge pull request #66 from jfisher-usgs/master
Browse files Browse the repository at this point in the history
Merge with upstream
  • Loading branch information
jfisher-usgs authored Apr 10, 2018
2 parents 784be0a + 12b9304 commit 3efb2f9
Show file tree
Hide file tree
Showing 31 changed files with 381 additions and 124 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -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="[email protected]", 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,
Expand Down
3 changes: 2 additions & 1 deletion NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -19,6 +19,7 @@ export(ExtractAlongTransect)
export(FindOptimalSubset)
export(FormatPval)
export(GetDaysInMonth)
export(GetTolColors)
export(Grid2Polygons)
export(IsPackageInstalled)
export(POSIXct2Character)
Expand Down
6 changes: 4 additions & 2 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -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.

Expand Down Expand Up @@ -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.
Expand Down
2 changes: 1 addition & 1 deletion R/AddGradientLegend.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)) {
Expand Down
2 changes: 1 addition & 1 deletion R/AddPoints.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)]
Expand Down
41 changes: 21 additions & 20 deletions R/AddWebMapElements.R
Original file line number Diff line number Diff line change
@@ -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.
#'
Expand Down Expand Up @@ -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...")
Expand All @@ -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"))
Expand All @@ -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)

Expand All @@ -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
Expand Down Expand Up @@ -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))
}


Expand Down
2 changes: 1 addition & 1 deletion R/ExportRasterStack.R
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down
5 changes: 2 additions & 3 deletions R/ExtractAlongTransect.R
Original file line number Diff line number Diff line change
Expand Up @@ -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))
}))
}
37 changes: 22 additions & 15 deletions R/FindOptimalSubset.R
Original file line number Diff line number Diff line change
Expand Up @@ -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) {

Expand Down Expand Up @@ -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)))
}
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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]])
Expand Down Expand Up @@ -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))
}
72 changes: 72 additions & 0 deletions R/GetTolColors.R
Original file line number Diff line number Diff line change
@@ -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)
}
17 changes: 10 additions & 7 deletions R/Grid2Polygons.R
Original file line number Diff line number Diff line change
Expand Up @@ -121,7 +121,7 @@
#' par(op)
#'

Grid2Polygons <- function(grd, zcol=1L, level=FALSE, at=NULL, cuts=20L,
Grid2Polygons <- function(grd, zcol=1, level=FALSE, at=NULL, cuts=20,
pretty=FALSE, xlim=NULL, ylim=NULL, zlim=NULL,
ply=NULL) {

Expand Down Expand Up @@ -217,17 +217,20 @@ Grid2Polygons <- function(grd, zcol=1L, level=FALSE, at=NULL, cuts=20L,
levs <- sort(unique(stats::na.omit(z)))

# find polygon nodes for each level
FUN <- function(i) .FindPolyNodes(segs[segs[, "z"] == i, c("a", "b")])
poly.nodes <- lapply(levs, FUN)
poly.nodes <- lapply(levs, function(i) {
.FindPolyNodes(segs[segs[, "z"] == i, c("a", "b")])
})

# build lists of 'Polygon' objects
FUN <- function(i) lapply(i, function(j) sp::Polygon(coords[j, ]))
poly <- lapply(poly.nodes, FUN)
poly <- lapply(poly.nodes, function(i) {
lapply(i, function(j) sp::Polygon(coords[j, ]))
})

# build list of 'Polygons' objects
ids <- make.names(1:length(poly), unique=TRUE)
FUN <- function(i) sp::Polygons(poly[[i]], ID=ids[i])
polys <- lapply(1:length(poly), FUN)
polys <- lapply(1:length(poly), function(i) {
sp::Polygons(poly[[i]], ID=ids[i])
})

# convert to 'SpatialPolygons' object, add datum and projection
sp.polys <- sp::SpatialPolygons(polys, proj4string=raster::crs(grd))
Expand Down
Loading

0 comments on commit 3efb2f9

Please sign in to comment.