Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
lintr (#5)
* lintr: trailing_blank_lines_linter and no_tab_lintr

* lintr. trailing white space

* lintr.  commas_linter

* infix_spaces_linter

* line_length_linter(100)

* single_quotes_linter

* fix merge lints

* assignment_linter

* closed_curly_linter and open_curly_linter

* errant u

* start paren lints

* cleaned up .lintr file

* add lintr to post success travis

* documented

* fix broken checks
  • Loading branch information
schloerke committed Feb 16, 2018
1 parent e2d8197 commit fad2665
Show file tree
Hide file tree
Showing 84 changed files with 1,208 additions and 1,151 deletions.
19 changes: 5 additions & 14 deletions .lintr
@@ -1,17 +1,8 @@
linters: with_defaults(
camel_case_linter = NULL, # 873
single_quotes_linter = NULL, # 541
infix_spaces_linter = NULL, # 377
assignment_linter = NULL, # 266
line_length_linter = NULL, # 168
commas_linter = NULL, # 164
spaces_left_parentheses_linter = NULL, # 41
trailing_whitespace_linter = NULL, # 40
commented_code_linter = NULL, # 30
closed_curly_linter = NULL, # 25
object_usage_linter = NULL, # 18
open_curly_linter = NULL, # 15
trailing_blank_lines_linter = NULL, # 5
no_tab_linter = NULL, # 4
camel_case_linter = NULL,
line_length_linter = NULL, # line_length_linter(100),
commented_code_linter = NULL,
object_usage_linter = NULL,
NULL
)
exclusions: list()
5 changes: 5 additions & 0 deletions .travis.yml
Expand Up @@ -12,3 +12,8 @@ notifications:
email:
on_success: change
on_failure: change

r_github_packages:
- jimhester/lintr
after_success:
- Rscript -e 'lintr::lint_package()'
98 changes: 49 additions & 49 deletions R/colors.R
Expand Up @@ -19,7 +19,7 @@
#' be consistent; if consistency is needed, you must provide a non-\code{NULL}
#' domain.
#' @param na.color The color to return for \code{NA} values. Note that
#' \code{na.color=NA} is valid.
#' \code{na.color = NA} is valid.
#' @param alpha Whether alpha channels should be respected or ignored. If
#' \code{TRUE} then colors without explicit alpha information will be treated
#' as fully opaque.
Expand All @@ -31,28 +31,28 @@
#' @return A function that takes a single parameter \code{x}; when called with a
#' vector of numbers (except for \code{colorFactor}, which expects
#' factors/characters), #RRGGBB color strings are returned (unless
#' \code{alpha=TRUE} in which case #RRGGBBAA may also be possible).
#' \code{alpha = TRUE} in which case #RRGGBBAA may also be possible).
#'
#' @export
colorNumeric <- function(palette, domain, na.color = "#808080", alpha = FALSE, reverse = FALSE) {
rng = NULL
rng <- NULL
if (length(domain) > 0) {
rng = range(domain, na.rm = TRUE)
rng <- range(domain, na.rm = TRUE)
if (!all(is.finite(rng))) {
stop("Wasn't able to determine range of domain")
}
}

pf = safePaletteFunc(palette, na.color, alpha)
pf <- safePaletteFunc(palette, na.color, alpha)

withColorAttr('numeric', list(na.color = na.color), function(x) {
withColorAttr("numeric", list(na.color = na.color), function(x) {
if (length(x) == 0 || all(is.na(x))) {
return(pf(x))
}

if (is.null(rng)) rng = range(x, na.rm = TRUE)
if (is.null(rng)) rng <- range(x, na.rm = TRUE)

rescaled = scales::rescale(x, from = rng)
rescaled <- scales::rescale(x, from = rng)
if (any(rescaled < 0 | rescaled > 1, na.rm = TRUE))
warning("Some values were outside the color scale and will be treated as NA")

Expand Down Expand Up @@ -88,7 +88,7 @@ getBins <- function(domain, x, bins, pretty) {
if (pretty) {
base::pretty(domain %||% x, n = bins)
} else {
rng = range(domain %||% x, na.rm = TRUE)
rng <- range(domain %||% x, na.rm = TRUE)
seq(rng[1], rng[2], length.out = bins + 1)
}
}
Expand All @@ -111,22 +111,22 @@ colorBin <- function(palette, domain, bins = 7, pretty = TRUE,
# domain usually needs to be explicitly provided (even if NULL) but not if
# breaks are specified
if (missing(domain) && length(bins) > 1) {
domain = NULL
domain <- NULL
}
autobin = is.null(domain) && length(bins) == 1
autobin <- is.null(domain) && length(bins) == 1
if (!is.null(domain))
bins = getBins(domain, NULL, bins, pretty)
numColors = if (length(bins) == 1) bins else length(bins) - 1
colorFunc = colorFactor(palette, domain = if (!autobin) 1:numColors,
bins <- getBins(domain, NULL, bins, pretty)
numColors <- if (length(bins) == 1) bins else length(bins) - 1
colorFunc <- colorFactor(palette, domain = if (!autobin) 1:numColors,
na.color = na.color, alpha = alpha, reverse = reverse)
pf = safePaletteFunc(palette, na.color, alpha)
pf <- safePaletteFunc(palette, na.color, alpha)

withColorAttr('bin', list(bins = bins, na.color = na.color), function(x) {
withColorAttr("bin", list(bins = bins, na.color = na.color), function(x) {
if (length(x) == 0 || all(is.na(x))) {
return(pf(x))
}
binsToUse = getBins(domain, x, bins, pretty)
ints = cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = FALSE)
binsToUse <- getBins(domain, x, bins, pretty)
ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = FALSE)
if (any(is.na(x) != is.na(ints)))
warning("Some values were outside the color scale and will be treated as NA")
colorFunc(ints)
Expand All @@ -146,9 +146,9 @@ colorQuantile <- function(palette, domain, n = 4,
reverse = FALSE) {

if (!is.null(domain)) {
bins = quantile(domain, probs, na.rm = TRUE, names = FALSE)
bins <- quantile(domain, probs, na.rm = TRUE, names = FALSE)
return(withColorAttr(
'quantile', list(probs = probs, na.color = na.color),
"quantile", list(probs = probs, na.color = na.color),
colorBin(palette, domain = NULL, bins = bins, na.color = na.color,
alpha = alpha, reverse = reverse)
))
Expand All @@ -157,12 +157,12 @@ colorQuantile <- function(palette, domain, n = 4,
# I don't have a precise understanding of how quantiles are meant to map to colors.
# If you say probs = seq(0, 1, 0.25), which has length 5, does that map to 4 colors
# or 5? 4, right?
colorFunc = colorFactor(palette, domain = 1:(length(probs) - 1),
colorFunc <- colorFactor(palette, domain = 1:(length(probs) - 1),
na.color = na.color, alpha = alpha, reverse = reverse)

withColorAttr('quantile', list(probs = probs, na.color = na.color), function(x) {
binsToUse = quantile(x, probs, na.rm = TRUE, names = FALSE)
ints = cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = FALSE)
withColorAttr("quantile", list(probs = probs, na.color = na.color), function(x) {
binsToUse <- quantile(x, probs, na.rm = TRUE, names = FALSE)
ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = FALSE)
if (any(is.na(x) != is.na(ints)))
warning("Some values were outside the color scale and will be treated as NA")
colorFunc(ints)
Expand Down Expand Up @@ -211,31 +211,31 @@ colorFactor <- function(palette, domain, levels = NULL, ordered = FALSE,
# domain usually needs to be explicitly provided (even if NULL) but not if
# levels are specified
if (missing(domain) && !is.null(levels)) {
domain = NULL
domain <- NULL
}

if (!is.null(levels) && anyDuplicated(levels)) {
warning("Duplicate levels detected")
levels = unique(levels)
levels <- unique(levels)
}
lvls = getLevels(domain, NULL, levels, ordered)
lvls <- getLevels(domain, NULL, levels, ordered)

force(palette)
withColorAttr('factor', list(na.color = na.color), function(x) {
force(palette) # palette loses scope
withColorAttr("factor", list(na.color = na.color), function(x) {
if (length(x) == 0 || all(is.na(x))) {
return(rep.int(na.color, length(x)))
}

lvls = getLevels(domain, x, lvls, ordered)
pf = safePaletteFunc(palette, na.color, alpha, nlevels = length(lvls) * ifelse(reverse, -1, 1))
lvls <- getLevels(domain, x, lvls, ordered)
pf <- safePaletteFunc(palette, na.color, alpha, nlevels = length(lvls) * ifelse(reverse, -1, 1))

origNa = is.na(x)
x = match(as.character(x), lvls)
origNa <- is.na(x)
x <- match(as.character(x), lvls)
if (any(is.na(x) != origNa)) {
warning("Some values were outside the color scale and will be treated as NA")
}

scaled = scales::rescale(as.integer(x), from = c(1, length(lvls)))
scaled <- scales::rescale(as.integer(x), from = c(1, length(lvls)))
if (any(scaled < 0 | scaled > 1, na.rm = TRUE)) {
warning("Some values were outside the color scale and will be treated as NA")
}
Expand All @@ -251,10 +251,10 @@ colorFactor <- function(palette, domain, levels = NULL, ordered = FALSE,
#' \item{A character vector of RGB or named colors. Examples: \code{palette()}, \code{c("#000000", "#0000FF", "#FFFFFF")}, \code{topo.colors(10)}}
#' \item{The name of an RColorBrewer palette, e.g. \code{"BuPu"} or \code{"Greens"}.}
#' \item{The full name of a viridis palette: \code{"viridis"}, \code{"magma"}, \code{"inferno"}, or \code{"plasma"}.}
#' \item{A function that receives a single value between 0 and 1 and returns a color. Examples: \code{colorRamp(c("#000000", "#FFFFFF"), interpolate="spline")}.}
#' \item{A function that receives a single value between 0 and 1 and returns a color. Examples: \code{colorRamp(c("#000000", "#FFFFFF"), interpolate = "spline")}.}
#' }
#' @examples
#' pal = colorBin("Greens", domain = 0:100)
#' pal <- colorBin("Greens", domain = 0:100)
#' pal(runif(10, 60, 100))
#'
#' \donttest{
Expand All @@ -268,7 +268,7 @@ colorFactor <- function(palette, domain, levels = NULL, ordered = FALSE,
#' # Categorical data; by default, the values being colored span the gamut...
#' previewColors(colorFactor("RdYlBu", domain = NULL), LETTERS[1:5])
#' # ...unless the data is a factor, without droplevels...
#' previewColors(colorFactor("RdYlBu", domain = NULL), factor(LETTERS[1:5], levels=LETTERS))
#' previewColors(colorFactor("RdYlBu", domain = NULL), factor(LETTERS[1:5], levels = LETTERS))
#' # ...or the domain is stated explicitly.
#' previewColors(colorFactor("RdYlBu", levels = LETTERS), LETTERS[1:5])
#' }
Expand All @@ -278,7 +278,7 @@ NULL


safePaletteFunc <- function(pal, na.color, alpha, nlevels = NULL) {
toPaletteFunc(pal, alpha=alpha, nlevels = nlevels) %>%
toPaletteFunc(pal, alpha = alpha, nlevels = nlevels) %>%
filterRGB() %>%
filterZeroLength() %>%
filterNA(na.color) %>%
Expand Down Expand Up @@ -312,7 +312,7 @@ brewer_pal <- function(palette, n = NULL) {
if (n == 1) {
colors[1]
} else if (n == 2) {
colors[c(1,3)]
colors[c(1, 3)]
} else {
colors
}
Expand All @@ -322,7 +322,7 @@ brewer_pal <- function(palette, n = NULL) {
# of an RColorBrewer palette that is marked as qualitative
toPaletteFunc.character <- function(pal, alpha, nlevels) {
if (length(pal) == 1 && pal %in% row.names(RColorBrewer::brewer.pal.info)) {
paletteInfo <- RColorBrewer::brewer.pal.info[pal,]
paletteInfo <- RColorBrewer::brewer.pal.info[pal, ]
if (!is.null(nlevels)) {
colors <- brewer_pal(pal, abs(nlevels))
} else {
Expand Down Expand Up @@ -354,8 +354,8 @@ toPaletteFunc.function <- function(pal, alpha, nlevels) {
#' @return An HTML-based list of the colors and values
#' @export
previewColors <- function(pal, values) {
heading = htmltools::tags$code(deparse(substitute(pal)))
subheading = htmltools::tags$code(deparse(substitute(values)))
heading <- htmltools::tags$code(deparse(substitute(pal)))
subheading <- htmltools::tags$code(deparse(substitute(values)))

htmltools::browsable(
with(htmltools::tags, htmltools::tagList(
Expand All @@ -381,7 +381,7 @@ previewColors <- function(pal, values) {
)
}

# colorRamp(space = 'Lab') throws error when called with
# colorRamp(space = "Lab") throws error when called with
# zero-length input
filterZeroLength <- function(f) {
force(f)
Expand All @@ -398,10 +398,10 @@ filterZeroLength <- function(f) {
filterNA <- function(f, na.color) {
force(f)
function(x) {
results = character(length(x))
nas = is.na(x)
results[nas] = na.color
results[!nas] = f(x[!nas])
results <- character(length(x))
nas <- is.na(x)
results[nas] <- na.color
results[!nas] <- f(x[!nas])
results
}
}
Expand All @@ -410,7 +410,7 @@ filterNA <- function(f, na.color) {
filterRGB <- function(f) {
force(f)
function(x) {
results = f(x)
results <- f(x)
if (is.character(results)) {
results
} else if (is.matrix(results)) {
Expand All @@ -424,7 +424,7 @@ filterRGB <- function(f) {
filterRange <- function(f) {
force(f)
function(x) {
x[x < 0 | x > 1] = NA
x[x < 0 | x > 1] <- NA
f(x)
}
}
21 changes: 10 additions & 11 deletions R/controls.R
@@ -1,34 +1,33 @@
#' @param html the content of the control. May be provided as string or as HTML
#' generated with Shiny/htmltools tags
#' @param position position of control: 'topleft', 'topright', 'bottomleft', or
#' 'bottomright'
#' @param position position of control: "topleft", "topright", "bottomleft", or
#' "bottomright"
#' @param className extra CSS classes to append to the control, space separated
#'
#' @describeIn map-layers Add arbitrary HTML controls to the map
#' @export
addControl <- function(
map, html, position = c('topleft', 'topright', 'bottomleft', 'bottomright'),
map, html, position = c("topleft", "topright", "bottomleft", "bottomright"),
layerId = NULL, className = "info legend", data = getMapData(map)
) {

position = match.arg(position)
position <- match.arg(position)

deps = htmltools::resolveDependencies(htmltools::findDependencies(html))
html = as.character(html)
deps <- htmltools::resolveDependencies(htmltools::findDependencies(html))
html <- as.character(html)

map$dependencies = c(map$dependencies, deps)
invokeMethod(map, data, 'addControl', html, position, layerId, className)
map$dependencies <- c(map$dependencies, deps)
invokeMethod(map, data, "addControl", html, position, layerId, className)
}

#' @export
#' @rdname remove
removeControl <- function(map, layerId) {
invokeMethod(map, NULL, 'removeControl', layerId)
invokeMethod(map, NULL, "removeControl", layerId)
}

#' @export
#' @rdname remove
clearControls <- function(map) {
invokeMethod(map, NULL, 'clearControls')
invokeMethod(map, NULL, "clearControls")
}

11 changes: 5 additions & 6 deletions R/data.R
Expand Up @@ -15,11 +15,11 @@
#' p = (p - min(p))/(max(p) - min(p))
#' plot(Lat ~ Long, data = uspop2000, cex = sqrt(p), asp = 1, col = rgb(1, 0, 0, .3))

if(FALSE){
uspop2000 = NULL
if (file.exists('inst/csv/uspop2000.csv')) {
uspop2000 = read.csv(
text = readLines('inst/csv/uspop2000.csv', encoding = 'UTF-8'),
if (FALSE) {
uspop2000 <- NULL
if (file.exists("inst/csv/uspop2000.csv")) {
uspop2000 <- read.csv(
text = readLines("inst/csv/uspop2000.csv", encoding = "UTF-8"),
stringsAsFactors = FALSE
)
}
Expand Down Expand Up @@ -56,4 +56,3 @@ NULL
#' "The Geography of Beer, sustainability in the food industry"
#' @format \code{sp::SpatialPointsDataFrame}
NULL

0 comments on commit fad2665

Please sign in to comment.