Merge pull request #83 from tomroh/dev

Fixing partial match and adding manual bins for numeric legend

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: leaflegend
 Type: Package
 Title: Add Custom Legends to 'leaflet' Maps
-Version: 1.2.0
+Version: 1.2.1
 Authors@R: c(
     person("Thomas", "Roh", email = "thomas@roh.engineering", role = c("aut", "cre")),
     person("Ricardo Rodrigo", "Basa", email = "radbasa@gmail.com", role = c("ctb")))

NEWS.md

@@ -1,3 +1,9 @@
+# leaflegend 1.2.1
+
+* `addLegendNumeric` now has the ability to use manual tick breaks and labels 
+when the `bins` argument is a numeric vector greater than length 1. This 
+only applies to vertically oriented legends.
+
 # leaflegend 1.2.0
 
 * `addLegendNumeric` gains `labelStyle` argument and significant improvements 

R/legend.R

@@ -1106,8 +1106,7 @@ addSymbols <- function(
     leaflet::addMarkers(map = map, lng = lng, lat = lat, icon = iconSymbols,
       data = data, ...)
   } else {
-    leaflet::addMarkers(map = map, icon = iconSymbols,
-      data = data, ...)
+    leaflet::addMarkers(map = map, icon = iconSymbols, data = data, ...)
   }
 }
 #' @export
@@ -1142,10 +1141,9 @@ addSymbolsSize <- function(
       fillOpacity = fillOpacity, strokeWidth = strokeWidth,
       width = sizes, data = data, ...)
   } else {
-    addSymbols(map = map, shape = shape, color = color,
-               fillColor = fillColor, opacity = opacity,
-               fillOpacity = fillOpacity, strokeWidth = strokeWidth,
-               width = sizes, data = data, ...)
+    addSymbols(map = map, shape = shape, color = color, fillColor = fillColor,
+      opacity = opacity, fillOpacity = fillOpacity, strokeWidth = strokeWidth,
+      width = sizes, data = data, ...)
   }
 }
 
@@ -1173,7 +1171,8 @@ addSymbolsSize <- function(
 #' @param bins
 #'
 #' an approximate number of tick-marks on the color gradient for the
-#' colorNumeric palette
+#' colorNumeric palette if it is of length one; you can also provide a
+#' numeric vector as the pre-defined breaks
 #'
 #' @param title
 #'
@@ -1445,20 +1444,29 @@ addLegendNumeric <- function(map,
                 length(map[["x"]][["calls"]]) + 1)
   values <- parseValues(values = values, data = data)
   rng <- range(values, na.rm = TRUE)
-  breaks <- pretty(values, bins)
+  bins <- parseValues(values = bins, data = data)
+  if (length(bins) > 1) {
+    if (!all(bins >= rng[1] & bins <= rng[2])) {
+      stop('Bins are outside range of values.')
+    }
+    breaks <- sort(c(rng, bins))
+  } else {
+    breaks <- pretty(values, bins)
+  }
   if (breaks[1] < rng[1]) {
     breaks[1] <- rng[1]
   }
   if (breaks[length(breaks)] > rng[2]) {
     breaks[length(breaks)] <- rng[2]
   }
-  colors <- pal(breaks)
   hasNa <- any(is.na(values))
   orientation <- match.arg(orientation)
   isVertical <- as.integer(orientation == 'vertical')
   isHorizontal <- as.integer(orientation == 'horizontal')
+  offsets <- seq(rng[1], rng[2], length.out = 10)
   if (decreasing) {
     breaks <- rev(breaks)
+    offsets <- rev(offsets)
     stdBreaks <- (1 - (breaks - rng[1]) / diff(rng)) *
       (height * isVertical + width * isHorizontal)
   } else {
@@ -1481,9 +1489,9 @@ addLegendNumeric <- function(map,
     orientation = orientation)
   tickText <- makeTickText(labels =  labels, breaks = stdBreaks[i],
     width = width, height = height, orientation = orientation)
-  svgGradient <- makeGradient(breaks = breaks, colors = colors,
-    height = height, width = width, id = id, fillOpacity = fillOpacity,
-    orientation = orientation, shape)
+  svgGradient <- makeGradient(breaks = offsets,
+    pal = pal,height = height, width = width, id = id,
+    fillOpacity = fillOpacity, orientation = orientation, shape)
   htmlElements <- assembleLegendWithTicks(
     width = width + (isVertical * tickLength * 2),
     height = height + (isHorizontal * tickLength * 2),
@@ -1501,17 +1509,17 @@ addLegendNumeric <- function(map,
     group = group, ...)
 }
 
-makeGradient <- function(breaks, colors, height, width, id, fillOpacity,
+makeGradient <- function(breaks, pal, height, width, id, fillOpacity,
   orientation, shape) {
   stops <- (breaks - min(breaks)) /
     (max(breaks) - min(breaks))
-  colors <- colors[order(stops)]
+  colors <- pal(breaks)[order(stops)]
   stops <- sort(stops)
   offsets <- sprintf('%.03f%%', 100 * stops)
   curvePercent <- ifelse(shape == 'stadium', '10%', '0')
   if (orientation == 'vertical') {
     htmltools::tagList(
-      htmltools::tags$def(
+      htmltools::tags$defs(
         htmltools::tags$linearGradient(
           id = id,
           x1 = 0, y1 = 0, x2 = 0, y2 = 1,
@@ -1528,7 +1536,7 @@ makeGradient <- function(breaks, colors, height, width, id, fillOpacity,
     )
   } else {
     htmltools::tagList(
-      htmltools::tags$def(
+      htmltools::tags$defs(
         htmltools::tags$linearGradient(
           id = id,
           x1 = 0, y1 = 0, x2 = 1, y2 = 0,
@@ -1648,11 +1656,8 @@ addLegendQuantile <- function(map,
   probs <- attr(pal, 'colorArgs')[['probs']]
   values <- parseValues(values = values, data = data)
   if ( is.null(numberFormat) ) {
-    labels <- sprintf(' %3.0f%%%s%3.0f%%',
-                      probs[-length(probs)] * 100,
-                      between,
+    labels <- sprintf(' %3.0f%%%s%3.0f%%', probs[-length(probs)] * 100, between,
                       probs[-1] * 100)
-
   } else {
     breaks <- stats::quantile(x = values, probs = probs, na.rm = TRUE)
     labels <- numberFormat(breaks)

inst/examples/examples.R

@@ -653,7 +653,11 @@ leaflet(quakes) %>%
     strokeWidth = 2)
 
 
-
+library(leaflet)
+library(leaflegend)
+data("quakes")
+baseSize <- 5
+numPal <- colorNumeric('viridis', 10^(quakes$mag))
 leaflet(quakes) |>
   addTiles() |>
   addLegendSize(
@@ -831,3 +835,94 @@ leaflet::leaflet(options = leaflet::leafletOptions(zoomControl = FALSE)) |>
     width = defaultSize, height = defaultSize, position = 'topright') |>
   addLegendImage(images = pchSvgI, labels = i-1,
     width = defaultSize, height = defaultSize, position = 'topleft')
+
+# Test Pre-defined Bins colorNumeric --------------------------------------
+library(leaflet)
+data("quakes")
+numPal <- colorNumeric('viridis', quakes$mag)
+leaflet(quakes) %>%
+  addTiles() %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    position = 'topright',
+    orientation = 'horizontal',
+    shape = 'rect',
+    decreasing = FALSE,
+    height = 20,
+    width = 100
+  ) %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    bins = c(5,6),
+    position = 'topright',
+    orientation = 'horizontal',
+    shape = 'rect',
+    decreasing = FALSE,
+    height = 20,
+    width = 100
+  ) %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    bins = ~range(mag),
+    position = 'topright',
+    orientation = 'horizontal',
+    shape = 'rect',
+    decreasing = FALSE,
+    height = 20,
+    width = 100
+  ) %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    position = 'topright',
+    orientation = 'vertical',
+    title = 'Default',
+    shape = 'rect',
+    decreasing = FALSE,
+    height = 100,
+    width = 20
+  ) %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    bins = seq(4, 6.4, length.out = 5),
+    numberFormat = function(x) sprintf('%.2f', x),
+    position = 'topright',
+    orientation = 'vertical',
+    title = htmltools::div('Manual Breaks', style ='margin-bottom:10px'),
+    shape = 'rect',
+    decreasing = TRUE,
+    height = 100,
+    width = 20
+  ) %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    bins = ~range(mag),
+    position = 'topright',
+    orientation = 'vertical',
+    title = htmltools::div('Min/Max w/ Formula', style ='margin-bottom:10px'),
+    numberFormat = function(x) sprintf('%.2f', x),
+    shape = 'rect',
+    decreasing = FALSE,
+    height = 100,
+    width = 20
+  ) %>%
+  addLegendNumeric(
+    pal = numPal,
+    values = ~mag,
+    bins = c(4, 5.2, 6.4),
+    position = 'topright',
+    orientation = 'vertical',
+    labels = c('Low', 'Mid', 'High'),
+    title = htmltools::div('Labels', style ='margin-bottom:10px'),
+    numberFormat = function(x) sprintf('%.2f', x),
+    shape = 'rect',
+    decreasing = TRUE,
+    height = 100,
+    width = 20
+  )
+

tests/testthat/test-legend.R

@@ -495,10 +495,21 @@ testthat::test_that('Numeric Legend', {
                          tickWidth = -1) %>%
     testthat::expect_error()
   # test results
-  numVert <- m %>% addLegendNumeric(pal = pal, values = c(1, NA, 3))
+  numVert <- m %>% addLegendNumeric(pal = pal, values = c(1, NA, 3),
+    decreasing = TRUE)
   numHori <- m %>% addLegendNumeric(pal = pal, values = c(1, NA, 3),
                                     orientation = 'horizontal',
     width = 100, height = 20)
+  numVert %>%
+    testthat::expect_no_error()
+  numHori %>%
+    testthat::expect_no_error()
+  m %>%
+    addLegendNumeric(pal = pal, values = ~x, bins = c(10, 11)) %>%
+    testthat::expect_error()
+  m %>%
+    addLegendNumeric(pal = pal, values = ~x, bins = c(1, 3)) %>%
+    testthat::expect_no_error()
 #   numVert %>%
 #     getElement('x') %>%
 #     getElement('calls') %>%
@@ -629,6 +640,10 @@ testthat::test_that('Categorical Legends', {
                           values = ~x,
                           numberFormat = 'fun') %>%
     testthat::expect_error()
+  m %>% addLegendQuantile(pal = palQuantile,
+    values = ~x,
+    numberFormat = NULL) %>%
+    testthat::expect_no_error()
   # test Bin args
   m %>% addLegendBin(pal = palBin,
                      orientation = 'up') %>%