R/legend.R
In leaflegend: Add Custom Legends to 'leaflet' Maps

Documented in addLegendAwesomeIcon addLegendBin addLegendFactor addLegendImage addLegendLine addLegendNumeric addLegendQuantile addLegendSize addLegendSymbol addLegendText addLegendTextSize addSymbols addSymbolsSize addText addTextSize availableShapes makeSvgUri makeSymbol makeSymbolIcons makeSymbolsSize makeSymbolText makeSymbolTextIcons sizeBreaks sizeNumeric

#' Add a Legend with Images
#'
#' Creates a legend with images that are embedded into a 'leaflet' map so that
#' images do not need to be packaged when saving a 'leaflet' map as HTML. Full
#' control over the label and title style. The 'leaflet' map is passed through
#' and the output is a control so that legend is fully integrated with other
#' functionalities.
#'
#' @param map
#'
#' a map widget object created from 'leaflet'
#'
#' @param images
#'
#' path to the image file
#'
#' @param labels
#'
#' labels for each image
#'
#' @param title
#'
#' the legend title, pass in HTML to style
#'
#' @param labelStyle
#'
#' character string of style argument for HTML text
#'
#' @param orientation
#'
#' stack the legend items vertically or horizontally
#'
#' @param width
#'
#' in pixels
#'
#' @param height
#'
#' in pixels
#'
#' @param group
#'
#' group name of a leaflet layer group
#'
#' @param className
#'
#' extra CSS class to append to the control, space separated
#'
#' @param ...
#'
#' arguments to pass to \link[leaflet]{addControl}
#'
#' @return
#'
#' an object from \link[leaflet]{addControl}
#'
#' @export
#'
#' @examples
#'
#' library(leaflet)
#' data(quakes)
#'
#' quakes1 <- quakes[1:10,]
#'
#' colors <- c('blue', 'red', 'yellow', 'green', 'orange', 'purple')
#' i <- as.integer(cut(quakes$mag, breaks = quantile(quakes$mag, seq(0,1,1/6)),
#'                     include.lowest = TRUE))
#' leafImg <- system.file(sprintf('img/leaf-%s.png', colors),
#'                        package = 'leaflegend')
#' leafIcons <- icons(
#'   iconUrl = leafImg[i],
#'   iconWidth = 133/236 * 50, iconHeight = 50
#' )
#' leaflet(data = quakes) %>% addTiles() %>%
#'   addMarkers(~long, ~lat, icon = leafIcons) %>%
#'   addLegendImage(images = leafImg,
#'                  labels = colors,
#'                  width = 133/236 * 50,
#'                  height = 50,
#'                  orientation = 'vertical',
#'                  title = htmltools::tags$div('Leaf',
#'                                              style = 'font-size: 24px;
#'                                              text-align: center;'),
#'                  position = 'topright')
#'
#'  # use raster images with size encodings
#'  height <- sizeNumeric(quakes$depth, baseSize = 40)
#'  width <- height * 38 / 95
#'  symbols <- icons(
#'    iconUrl = leafImg[4],
#'    iconWidth = width,
#'    iconHeight = height)
#'  probs <- c(.2, .4, .6, .8)
#'  leaflet(quakes) %>%
#'    addTiles() %>%
#'    addMarkers(icon = symbols,
#'               lat = ~lat, lng = ~long) %>%
#'    addLegendImage(
#'      images = rep(leafImg[4], 4),
#'      labels = round(quantile(height, probs = probs), 0),
#'      width = quantile(height, probs = probs) * 38 / 95,
#'      height = quantile(height, probs = probs),
#'      title = htmltools::tags$div(
#'        'Leaf',
#'        style = 'font-size: 24px; text-align: center; margin-bottom: 5px;'),
#'      position = 'topright', orientation = 'vertical')
addLegendImage <- function(
    map,
    images,
    labels,
    title = NULL,
    labelStyle = 'font-size: 24px; vertical-align: middle;',
    orientation = c('vertical', 'horizontal'),
    width = 20,
    height = 20,
    group = NULL,
    className = 'info legend leaflet-control',
    ...) {
  stopifnot(length(images) == length(labels))
  stopifnot( all(width >= 0) && all(height >= 0) )
  orientation <- match.arg(orientation)
  if ( orientation == 'vertical' ) {
    htmlTag <- htmltools::tags$div
  } else {
    htmlTag <- htmltools::tags$span
  }
  if ( inherits(images, 'svgURI') ) {
    images <- list(images)
  }
  htmlElements <- Map(
    img = images,
    label = labels,
    htmlTag = list(htmlTag),
    width = width,
    height = height,
    maxWidth = max(width) * (orientation == 'vertical'),
    f =
      function(img, label, htmlTag, height, width, maxWidth) {
        marginWidth <- max(0, (maxWidth - width) / 2)
        imgStyle <- sprintf(
      'vertical-align: %s; margin: %spx; margin-right: %spx; margin-left: %spx',
      'middle', 5, marginWidth, marginWidth)
        if ( inherits(img, 'svgURI') ) {
          imgTag <- htmltools::tags$img(
            src = img,
            style = imgStyle,
            height = height,
            width = width
          )
        } else {
          fileExt <- tolower(sub('.+(\\.)([a-zA-Z]+)', '\\2', img))
          stopifnot(fileExt %in% c('png', 'jpg', 'jpeg'))
          imgTag <- htmltools::tags$img(
            src = sprintf(
              'data:image/%s;base64,%s',
              fileExt,
              base64enc::base64encode(img)
            ),
            style = imgStyle,
            height = height,
            width = width
          )
        }
        htmlTag(imgTag, htmltools::tags$span(label, style = labelStyle))
      }
  )
  htmlElements <- addTitle(title = title, htmlElements = htmlElements)
  leaflegendAddControl(map, html = htmltools::tagList(htmlElements),
                       className = className, group = group, ...)
}

#' Create Map Symbols for 'leaflet' maps
#'
#'
#'
#'
#' @param shape
#'
#' the desired shape of the symbol, See \link[leaflegend]{availableShapes}
#'
#' @param width
#'
#' in pixels
#'
#' @param height
#'
#' in pixels
#'
#' @param color
#'
#' color of the symbol
#'
#' @param fillColor
#'
#' fill color of symbol
#'
#' @param opacity
#'
#' opacity of color
#'
#' @param fillOpacity
#'
#' opacity of fillColor
#'
#' @param strokeWidth
#'
#' width in pixels of symbol outline
#'
#' @param label
#'
#' character string to display at the center of the symbol
#'
#' @param ...
#'
#' arguments to pass to
#'
#' svg shape tag for makeSymbol, makeSymbolIcons, makeSymbolsSize
#'
#' svg text tag for makeSymbolText, makeSymbolTextIcons
#'
#' \link[leaflet]{addMarkers} for addSymbols, addSymbolsSize, addText, addTextSize
#'
#' \link[base]{pretty} for sizeBreaks
#'
#' @return
#'
#' HTML svg element
#'
#' @examples
#' library(leaflet)
#' data(quakes)
#'
#' # symbol with a label centered inside
#' makeSymbol('circle', width = 24, color = 'black', fillColor = 'steelblue',
#'            fillOpacity = 0.8, label = 'A')
#'
#' # map markers with per-point labels
#' quakes$label <- as.character(seq_len(nrow(quakes)))
#' leaflet(quakes[1:20, ]) %>%
#'   addTiles() %>%
#'   addSymbols(lat = ~lat, lng = ~long, color = 'black',
#'              fillColor = 'steelblue', fillOpacity = 0.8,
#'              label = ~label)
#'
#' @name mapSymbols
#'
#' @export
#'
makeSymbol <- function(shape, width, height = width, color, fillColor = color,
                       opacity = 1, fillOpacity = opacity, label = NULL, ...) {
  svg <- makeSymbolElement(shape = shape, width, height = height,
    color = color, fillColor = fillColor, opacity = opacity,
    fillOpacity = fillOpacity, label = label, ...)
  strokeWidth <- 1
  if ( 'stroke-width' %in% names(list(...)) ) {
    strokeWidth <- list(...)[['stroke-width']]
  }
  makeSvgUri(svg = svg, width = width, height = height,
    strokeWidth = strokeWidth)
}
makeSymbolElement <- function(shape, width, height = width, color,
  fillColor = color, opacity = 1, fillOpacity = opacity, label = NULL, ...) {
  stopifnot(is.numeric(width) & is.numeric(height))
  stopifnot(is.numeric(opacity) & is.numeric(fillOpacity))
  stopifnot(!is.na(shape))
  if (shape %in% availableShapes()[['default']]) {
    svg <- symbolSvg(shape = shape,  width = width, height = height,
      color = color, fillColor = fillColor, opacity = opacity,
      fillOpacity = fillOpacity, ...)
  } else if (shape %in% availableShapes()[['pch']] || shape %in%
      (seq_along(availableShapes()[['pch']]) - 1)) {
    svg <- pchSvg(shape = shape,  width = width, height = height,
      color = color, fillColor = fillColor, opacity = opacity,
      fillOpacity = fillOpacity, ...)
  } else if (shape %in% availableShapes()[['special']]) {
    svg <- specialSvg(shape = shape,  width = width, height = height,
      color = color, fillColor = fillColor, opacity = opacity,
      fillOpacity = fillOpacity, ...)
  } else {
    stop('Argument "shape" is invalid. See `availableShapes()`.')
  }
  if ( !is.null(label) ) {
    labelElement <- htmltools::tags$text(
      x = '50%',
      y = '50%',
      'dominant-baseline' = 'central',
      'text-anchor' = 'middle',
      'font-size' = paste0(round(min(width, height) * 0.6), 'px'),
      'font-family' = 'sans-serif',
      fill = color,
      'stroke-width' = 0,
      label
    )
    svg <- htmltools::tagList(svg, labelElement)
  }
  svg
}
symbolSvg <- function(shape, width, height, color, fillColor, opacity,
  fillOpacity, ...) {   
  strokeWidth <- 1
  if ( 'stroke-width' %in% names(list(...)) ) {
    strokeWidth <- list(...)[['stroke-width']]
  }
  switch(
    shape,
    'rect' = htmltools::tags$rect(
      id = 'rect',
      x = strokeWidth,
      y = strokeWidth,
      height = height,
      width = width,
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'circle' = htmltools::tags$circle(
      id = 'circle',
      cx = height / 2 + strokeWidth,
      cy = height / 2 + strokeWidth,
      r = height / 2,
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'triangle' = htmltools::tags$polygon(
      id = 'triangle',
      points = sprintf('%s,%s %s,%s %s,%s',
        strokeWidth,
        height + strokeWidth,
        width + strokeWidth,
        height + strokeWidth,
        width / 2  + strokeWidth,
        strokeWidth),
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'plus' = htmltools::tags$polygon(
      id = 'plus',
      points = drawPlus(width = width, height = height, offset = strokeWidth),
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'cross' = htmltools::tags$polygon(
      id = 'cross',
      points = drawCross(width = width, height = height, offset = strokeWidth),
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'diamond' = htmltools::tags$polygon(
      id = 'diamond',
      points = drawDiamond(width = width, height = height,
        offset = strokeWidth),
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'star' = htmltools::tags$polygon(
      id = 'star',
      points = drawStar(width = width, height = height, offset = strokeWidth),
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'stadium' = htmltools::tags$rect(
      id = 'stadium',
      x = strokeWidth,
      y = strokeWidth,
      height = height,
      width = width,
      rx = "25%",
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'line' = htmltools::tags$line(
      id = 'line',
      x1 = 0,
      x2 = width + strokeWidth * 2,
      y1 = height / 2 + strokeWidth,
      y2 = height / 2 + strokeWidth,
      stroke = color,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    'polygon' = htmltools::tags$polygon(
      id = 'polygon',
      points = drawPolygon(n = 5, width = width, height = height,
        offset = strokeWidth),
      stroke = color,
      fill = fillColor,
      'stroke-opacity' = opacity,
      'fill-opacity' = fillOpacity,
      ...
    ),
    stop('Invalid shape argument.')
  )
}
pchSvg <- function(shape, width, height, color, fillColor, opacity,
  fillOpacity, ...) {
  hexPercentOffset <- .8
  strokeWidth <- 1
  if ( 'stroke-width' %in% names(list(...)) ) {
    strokeWidth <- list(...)[['stroke-width']]
  }
  pchShape <-
    list(
      'open-rect' = htmltools::tags$g(
        transform = sprintf('translate(%f %f)', strokeWidth, strokeWidth),
        htmltools::tags$rect(
          id = 'open-rect',
          x = 0,
          y = 0,
          height = height,
          width = width,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'open-circle' = htmltools::tags$g(
        transform = sprintf('translate(%f %f)', strokeWidth, strokeWidth),
        htmltools::tags$circle(
          id = 'circle',
          cx = height / 2,
          cy = height / 2,
          r = height / 2,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'open-triangle' = htmltools::tags$g(
        transform = sprintf('translate(%f %f)', strokeWidth, strokeWidth),
        htmltools::tags$polygon(
          id = 'triangle',
          points = drawTriangle(width = width, height = height,
            offset = 0),
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'simple-plus' = htmltools::tags$g(
        transform = sprintf('translate(%f %f)', strokeWidth, strokeWidth),
        htmltools::tags$line(
          id = 'pline1',
          x1 = 0,
          x2 = width,
          y1 = height / 2,
          y2 = height / 2,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'pline2',
          x1 = width / 2,
          x2 = width / 2,
          y1 = 0,
          y2 = height,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'simple-cross' = htmltools::tags$g(
        transform = sprintf('translate(%f %f)', strokeWidth, strokeWidth),
        htmltools::tags$line(
          id = 'cline1',
          x1 = 0,
          x2 = width,
          y1 = 0,
          y2 = height,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'cline2',
          x1 = 0,
          x2 = width,
          y1 = height,
          y2 = 0,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'open-diamond' =  htmltools::tags$polygon(
        id = 'diamond',
        points = drawDiamond(width = width, height = height,
          offset = strokeWidth),
        stroke = color,
        fill = 'transparent',
        'stroke-opacity' = opacity,
        ...
      ),
      'open-down-triangle' = htmltools::tags$polygon(
        id = 'triangle',
        points = drawTriangle(width = width, height = height,
          offset = strokeWidth),
        stroke = color,
        fill = 'transparent',
        'stroke-opacity' = opacity,
        transform = sprintf('rotate(180 %f %f)', height / 2 + strokeWidth,
          width / 2 + strokeWidth),
        ...
      ),
      'cross-rect' = htmltools::tags$g(
        htmltools::tags$line(
          id = 'cline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'cline2',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height + strokeWidth,
          y2 = strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$rect(
          id = 'open-rect',
          x = strokeWidth,
          y = strokeWidth,
          height = height,
          width = width,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'simple-star' = htmltools::tags$g(
        htmltools::tags$line(
          id = 'pline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height / 2 + strokeWidth,
          y2 = height / 2 + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'pline2',
          x1 = width / 2 + strokeWidth,
          x2 = width / 2 + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'cline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'cline2',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height + strokeWidth,
          y2 = strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'plus-diamond' = htmltools::tags$g(
        htmltools::tags$line(
          id = 'pline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height / 2 + strokeWidth,
          y2 = height / 2 + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'pline2',
          x1 = width / 2 + strokeWidth,
          x2 = width / 2 + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$polygon(
          id = 'diamond',
          points = drawDiamond(width = width, height = height,
            offset = strokeWidth),
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'plus-circle' = htmltools::tags$g(
        htmltools::tags$line(
          id = 'pline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height / 2 + strokeWidth,
          y2 = height / 2 + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'pline2',
          x1 = width / 2 + strokeWidth,
          x2 = width / 2 + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$circle(
          id = 'circle',
          cx = height / 2 + strokeWidth,
          cy = height / 2 + strokeWidth,
          r = height / 2,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'hexagram' = htmltools::tags$g(
        transform = sprintf('translate(%f %f)', strokeWidth,
          strokeWidth + height * (1 - hexPercentOffset) / 2),
        htmltools::tags$polygon(
          id = 'triangle',
          points = drawTriangle(width = width * hexPercentOffset,
            height = height * hexPercentOffset,
            offset = 0),
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          transform = sprintf('rotate(180 %f %f) translate(%f %f)',
            height * hexPercentOffset / 2,
            width * hexPercentOffset / 2,
            -width * (1 - hexPercentOffset) / 2,
            -height * (1 - hexPercentOffset) / 2),
          ...
        ),
        htmltools::tags$polygon(
          id = 'triangle',
          points = drawTriangle(width = width * hexPercentOffset,
            height = height * hexPercentOffset,
            offset = 0),
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          transform = sprintf('translate(%f %f)',
            width * (1 - hexPercentOffset) / 2,
            -height * (1 - hexPercentOffset) / 2),
          ...
        )
      ),
      'plus-rect' = htmltools::tags$g(
        htmltools::tags$line(
          id = 'pline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height / 2 + strokeWidth,
          y2 = height / 2 + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'pline2',
          x1 = width / 2 + strokeWidth,
          x2 = width / 2 + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$rect(
          id = 'open-rect',
          x = strokeWidth,
          y = strokeWidth,
          height = height,
          width = width,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'cross-circle' = htmltools::tags$g(
        htmltools::tags$line(
          id = 'cline1',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = strokeWidth,
          y2 = height + strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$line(
          id = 'cline2',
          x1 = strokeWidth,
          x2 = width + strokeWidth,
          y1 = height + strokeWidth,
          y2 = strokeWidth,
          stroke = color,
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$circle(
          id = 'circle',
          cx = height / 2 + strokeWidth,
          cy = height / 2 + strokeWidth,
          r = height / 2,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'triangle-rect' = htmltools::tags$g(
        htmltools::tags$polygon(
          id = 'triangle',
          points = drawTriangle(width = width, height = height,
            offset = strokeWidth),
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        ),
        htmltools::tags$rect(
          id = 'open-rect',
          x = strokeWidth,
          y = strokeWidth,
          height = height,
          width = width,
          stroke = color,
          fill = 'transparent',
          'stroke-opacity' = opacity,
          ...
        )
      ),
      'solid-rect' = htmltools::tags$rect(
        id = 'rect',
        x = strokeWidth,
        y = strokeWidth,
        height = height,
        width = width,
        stroke = 'transparent',
        fill = coalesceMissing(fillColor, color),
        'fill-opacity' = fillOpacity,
        ...
      ),
      'solid-circle-md' = htmltools::tags$circle(
        id = 'circle',
        cx = height / 2 + strokeWidth,
        cy = height / 2 + strokeWidth,
        r =  height *  3 / 4 / 2,
        stroke = 'transparent',
        fill = coalesceMissing(fillColor, color),
        'fill-opacity' = fillOpacity,
        ...
      ),
      'solid-triangle' = htmltools::tags$polygon(
        id = 'triangle',
        points = drawTriangle(width = width, height = height,
          offset = strokeWidth),
        stroke = 'transparent',
        fill = coalesceMissing(fillColor, color),
        'fill-opacity' = fillOpacity,
        ...
      ),
      'solid-diamond' = htmltools::tags$polygon(
        id = 'diamond',
        points = drawDiamond(width = width, height = height,
          offset = strokeWidth),
        stroke = 'transparent',
        fill = coalesceMissing(fillColor, color),
        'fill-opacity' = fillOpacity,
        ...
      ),
      'solid-circle-bg' = htmltools::tags$circle(
        id = 'circle',
        cx = height / 2 + strokeWidth,
        cy = height / 2 + strokeWidth,
        r =  height *  4 / 4 / 2,
        stroke = 'transparent',
        fill = coalesceMissing(fillColor, color),
        'fill-opacity' = fillOpacity,
        ...
      ),
      'solid-circle-sm' = htmltools::tags$circle(
        id = 'circle',
        cx = height / 2 + strokeWidth,
        cy = height / 2 + strokeWidth,
        r = height *  2 / 4 / 2,
        stroke = 'transparent',
        fill = coalesceMissing(fillColor, color),
        'fill-opacity' = fillOpacity,
        ...
      ),
      'circle' = htmltools::tags$circle(
        id = 'circle',
        cx = height / 2 + strokeWidth,
        cy = height / 2 + strokeWidth,
        r = height / 2,
        stroke = color,
        fill = fillColor,
        'stroke-opacity' = opacity,
        'fill-opacity' = fillOpacity,
        ...
      ),
      'rect' = htmltools::tags$rect(
        id = 'rect',
        x = strokeWidth,
        y = strokeWidth,
        height = height,
        width = width,
        stroke = color,
        fill = fillColor,
        'stroke-opacity' = opacity,
        'fill-opacity' = fillOpacity,
        ...
      ),
      'diamond' = htmltools::tags$polygon(
        id = 'diamond',
        points = drawDiamond(width = width, height = height,
          offset = strokeWidth),
        stroke = color,
        fill = fillColor,
        'stroke-opacity' = opacity,
        'fill-opacity' = fillOpacity,
        ...
      ),
      'triangle' = htmltools::tags$polygon(
        id = 'triangle',
        points = drawTriangle(width = width, height = height,
          offset = strokeWidth),
        stroke = color,
        fill = fillColor,
        'stroke-opacity' = opacity,
        'fill-opacity' = fillOpacity,
        ...
      ),
      'down-triangle' = htmltools::tags$polygon(
        id = 'triangle',
        points = drawTriangle(width = width, height = height,
          offset = strokeWidth),
        stroke = color,
        fill = fillColor,
        'stroke-opacity' = opacity,
        'fill-opacity' = fillOpacity,
        transform = sprintf('rotate(180 %f %f)', height / 2 + strokeWidth,
          width / 2 + strokeWidth),
        ...
      )
    )
  if (is.numeric(shape)) {
    shape <- shape + 1L
  } else {
    if (!shape %in% names(pchShape)) {
      stop(sprintf('"%s" is not a valid pch name', shape))
    }
  }
  pchShape[[shape]]
}
specialSvg <- function(shape, width, height, color, fillColor, opacity,
  fillOpacity, ...) {
  dots <- list(...)
  strokeWidth <- 1
  if ( shape %in% 'text' ) {
    strokeWidth <- 0
  }
  if ( 'stroke-width' %in% names(dots) ) {
    strokeWidth <- dots[['stroke-width']]
    dots[['stroke-width']] <- NULL
  }
  switch(
    shape,
    'text' = do.call(htmltools::tags$text, c(
      list(
        id = 'text',
        x = '50%',
        y = '50%',
        'dominant-baseline' = 'central',
        'text-anchor' = 'middle',
        'font-size' = paste0(round(min(width, height) * 0.6), 'px'),
        # 'font-family' = 'sans-serif',
        # 'textLength' = width,
        # 'lengthAdjust' = 'spacingAndGlyphs',
        fill = fillColor,
        'fill-opacity' = fillOpacity,
        stroke = color,
        'stroke-opacity' = opacity,
        'stroke-width' = strokeWidth,
        'abc'
      ),
      dots
    )),
    stop('Invalid shape argument.')
  )
}
.makeSymbolFigure <- function(shape, dir = 'man/figures', color = 'black',
    fillColor = NULL, opacity = 1, fillOpacity = 1, ...) {
  shapes <- availableShapes()
  if (is.null(fillColor)) {
    fillColor <- 'transparent'
    if (shape %in% shapes[['special']]) {
      fillColor <- color
    }
  }
  strokeWidth <- 2
  inner <- 50
  total <- inner + strokeWidth * 2
  label_y <- total + 20
  shapeElement <- makeSymbolElement(
    shape = shape,
    width = inner,
    height = inner,
    color = color,
    fillColor = fillColor,
    opacity = opacity,
    fillOpacity = fillOpacity,
    'stroke-width' = strokeWidth,
    ...
  )
  svgTag <- htmltools::tags$svg(
    xmlns = 'http://www.w3.org/2000/svg',
    version = '1.1',
    width = total,
    height = label_y,
    style = 'background-color: white;',
    shapeElement,
    htmltools::tags$text(
      x = total / 2,
      y = label_y - 4,
      'font-family' = 'sans-serif',
      'text-anchor' = 'middle',
      'font-size' = '12px',
      shape
    )
  )
  isPchOnly <- shape %in% shapes[['pch']] &&
    !shape %in% c(shapes[['default']], shapes[['special']])
  suffix <- '-pch.svg'
  if (!isPchOnly) {
    suffix <- '.svg'
  }
  filename <- sprintf('%s%s', shape, suffix)
  writeLines(as.character(svgTag), file.path(dir, filename))
}
coalesceMissing <- function(x, y) {
  if (missing(x)) y else x
}
#' @param svg
#'
#' inner svg tags for symbol
#'
#' @name mapSymbols
#'
#' @export
#'
makeSvgUri <- function(svg, width, height, strokeWidth) {
  svgURI <-
    sprintf('data:image/svg+xml,%s',
      utils::URLencode(as.character(
        htmltools::tags$svg(
          xmlns = "http://www.w3.org/2000/svg",
          version = "1.1",
          width = width + strokeWidth * 2,
          height = height + strokeWidth * 2,
          svg
        )
      ), reserved = TRUE))
  structure(svgURI, class = c(class(svgURI), 'svgURI'))
}

makeLegendSymbol <- function(label, labelStyle,
  imgStyle = "vertical-align: middle; margin: 1px;", ...) {
  shapeTag <- makeSymbol(...)
  htmltools::tagList(
    htmltools::tags$img(src = shapeTag,
                        style = imgStyle),
    htmltools::tags$span(label,
                         style =
                           sprintf("vertical-align: middle; padding: 1px; %s",
                                         labelStyle))
  )
}

drawPlus <- function(width, height, offset = 0) {
  x <- width * c(rep(c(.4, 0, .4, .6, 1, .6), each = 2), .4) + offset
  y <- height * c(0, rep(c(.4, .6, 1, .6, .4, 0), each = 2)) + offset
  paste(x, y, sep = ',', collapse = ' ')
}

drawDiamond <- function(width, height, offset = 0) {
  x <- width * c( .5, 0, .5, 1, .5) + offset
  y <- height * c(0, .5, 1, .5, 0) + offset
  paste(x, y, sep = ',', collapse = ' ')
}

drawCross <- function(width, height, offset = 0) {
  a <- sqrt(2) / 10
  x <- width *  c(a, 0, .5 - a, 0, a, .5, 1 - a, 1, .5 + a, 1, 1 - a, .5, a) +
    offset
  y <- height * c(0, a, .5, 1 - a, 1, .5 + a, 1, 1 - a, .5, a, 0, .5 - a, 0) +
    offset
  paste(x, y, sep = ',', collapse = ' ')
}
drawStar <- function(width, height, offset = 0) {
  x <- width * c(0.4, 0.4, 0.1414214, 0, 0.2585786, 0, 0, 0.2585786, 0,
                 0.1414214, 0.4, 0.4, 0.6, 0.6, 0.8585786, 1, 0.7414214, 1, 1,
                 0.7414214, 1, 0.8585786, 0.6, 0.6, 0.4) + offset
  y <- height * c(0, 0.2585786, 0, 0.1414214, 0.4, 0.4, 0.6, 0.6, 0.8585786, 1,
                  0.7414214, 1, 1, 0.7414214, 1, 0.8585786, 0.6, 0.6, 0.4, 0.4,
                  0.1414214, 0, 0.2585786, 0, 0) + offset
  paste(x, y, sep = ',', collapse = ' ')
}
drawPolygon <- function(n, width = 1, height = 1, offset = 0) {
  stopifnot(n > 0 || !is.integer(n))
  radians <- seq(-pi, pi, by = 2 * pi / n)
  if ( n %% 2 == 0 ) {
    x <- (cos(radians) + 1) * 1 / 2 * width + offset
    y <- (sin(radians) + 1) * 1 / 2 * height + offset
  } else {
    radians <- seq(-pi, pi, by = 2 * pi / n)
    x <- (sin(radians) + 1) * 1 / 2 * width + offset
    y <- (cos(radians) + 1) * 1 / 2 * height + offset
  }
  paste(x, y, sep = ',', collapse = ' ')
}
drawTriangle <- function(width, height, offset) {
  sprintf('%s,%s %s,%s %s,%s',
    offset,
    height + offset,
    width + offset,
    height + offset,
    width / 2  + offset,
    offset)
}

#' @export
#'
#' @rdname mapSymbols
makeSymbolIcons <- function(shape,
  color,
  fillColor = color,
  opacity,
  fillOpacity = opacity,
  strokeWidth = 1,
  width,
  height = width,
  label = NULL,
  ...) {
  args <- list(
    makeSymbol,
    shape = shape,
    width = width,
    height = height,
    color = color,
    fillColor = fillColor,
    opacity = opacity,
    fillOpacity = fillOpacity,
    `stroke-width` = strokeWidth,
    ...
  )
  if (!is.null(label)) {
    args <- append(args, list(label = label))
  }
  symbols <- do.call(Map, args)
  leaflet::icons(
    iconUrl = unname(symbols),
    iconAnchorX = width / 2 + strokeWidth,
    iconAnchorY = height / 2 + strokeWidth
  )
}

#' @param text
#'
#' character string to render inside the svg
#'
#' @param fontSize
#'
#' size of the text in pixels; defaults to \code{round(min(width, height) * 0.6)}
#'
#' @param fontFamily
#'
#' optional font family for the svg text; if \code{NULL} the browser default is
#' used
#'
#' @examples
#'
#' library(leaflet)
#' data(quakes)
#' quakes1 <- quakes[1:10,]
#'
#' # makeSymbolText returns a single SVG data URI
#' makeSymbolText(text = 'A', width = 30, color = 'red')
#'
#' # makeSymbolTextIcons builds a vector of icons
#' iconSet <- makeSymbolTextIcons(text = LETTERS[1:nrow(quakes1)],
#'                                width = 30, color = 'white',
#'                                fillColor = 'navy')
#' leaflet(quakes1) %>%
#'   addTiles() %>%
#'   addMarkers(lng = ~long, lat = ~lat, icon = iconSet)
#'
#' # addText draws text labels at each location
#' leaflet(quakes1) %>%
#'   addTiles() %>%
#'   addText(lng = ~long, lat = ~lat,
#'           text = ~as.character(seq_len(nrow(quakes1))),
#'           color = 'white', fillColor = 'red', width = 30)
#'
#' # addTextSize scales text by a numeric variable
#' leaflet(quakes1) %>%
#'   addTiles() %>%
#'   addTextSize(lng = ~long, lat = ~lat,
#'               text = ~as.character(round(mag, 1)),
#'               values = ~mag, color = 'black', fillColor = 'yellow',
#'               baseSize = 30)
#'
#' @export
#'
#' @rdname mapSymbols
makeSymbolText <- function(text, width, height = width, color = 'black',
                           fillColor = color, opacity = 1,
                           fillOpacity = opacity,
                           fontSize = round(min(width, height) * 0.6),
                           fontFamily = NULL, ...) {
  stopifnot(is.numeric(width) & is.numeric(height))
  stopifnot(is.numeric(opacity) & is.numeric(fillOpacity))
  stopifnot(is.numeric(fontSize) && fontSize >= 0)
  dots <- list(...)
  strokeWidth <- 0
  if ( 'stroke-width' %in% names(dots) ) {
    strokeWidth <- dots[['stroke-width']]
    dots[['stroke-width']] <- NULL
  }
  svg <- do.call(htmltools::tags$text, c(
    list(
      id = 'text',
      x = '50%',
      y = '50%',
      'dominant-baseline' = 'central',
      'text-anchor' = 'middle',
      'font-size' = paste0(fontSize, 'px'),
      'font-family' = fontFamily,
      # 'textLength' = width,
      # 'lengthAdjust' = 'spacingAndGlyphs',
      fill = fillColor,
      'fill-opacity' = fillOpacity,
      stroke = color,
      'stroke-opacity' = opacity,
      'stroke-width' = strokeWidth,
      text
    ),
    dots
  ))
  makeSvgUri(svg = svg, width = width, height = height,
             strokeWidth = strokeWidth)
}

#' @export
#'
#' @rdname mapSymbols
makeSymbolTextIcons <- function(text,
                                color = 'black',
                                fillColor = color,
                                opacity = 1,
                                fillOpacity = opacity,
                                strokeWidth = 0,
                                width,
                                height = width,
                                fontFamily = NULL,
                                ...) {
  mapArgs <- list(
    f = makeSymbolText,
    text = text,
    width = width,
    height = height,
    color = color,
    fillColor = fillColor,
    opacity = opacity,
    fillOpacity = fillOpacity,
    `stroke-width` = strokeWidth,
    ...
  )
  if (!is.null(fontFamily)) {
    mapArgs[['fontFamily']] <- fontFamily
  }
  symbols <- do.call(Map, mapArgs)
  leaflet::icons(
    iconUrl = unname(symbols),
    iconAnchorX = width / 2 + strokeWidth,
    iconAnchorY = height / 2 + strokeWidth
  )
}
#' @param map
#'
#' a map widget object created from 'leaflet'
#'
#' @param lng
#'
#' a numeric vector of longitudes, or a one-sided formula of the form \code{~x}
#' where \code{x} is a variable in \code{data}; by default
#' (if not explicitly provided), it will be automatically inferred from data
#' by looking for a column named \code{lng}, \code{long}, or \code{longitude}
#' (case-insensitively)
#'
#' @param lat
#'
#' a vector of latitudes or a formula (similar to the \code{lng} argument; the
#' names \code{lat} and \code{latitude} are used when guessing the latitude
#' column from \code{data})
#'
#' @param values
#'
#' the values used to generate shapes; can be omitted for a single type of
#' shape
#'
#' @param shape
#'
#' the desired shape of the symbol, See \link[leaflegend]{availableShapes}
#'
#' @param color
#'
#' stroke color
#'
#' @param fillColor
#'
#' fill color
#'
#' @param opacity
#'
#' stroke opacity
#'
#' @param fillOpacity
#'
#' fill opacity
#'
#' @param strokeWidth
#'
#' stroke width in pixels
#'
#' @param width
#'
#' in pixels
#'
#' @param height
#'
#' in pixels
#'
#' @param dashArray
#'
#' a string or vector/list of strings that defines the stroke dash pattern
#'
#' @param label
#'
#' a character vector of labels to display at the center of each symbol
#'
#' @param data
#'
#' the data object from which the argument values are derived; by default, it
#' is the \code{data} object provided to \code{leaflet()} initially, but can be
#' overridden
#'
#' @export
#'
#' @rdname mapSymbols
addSymbols <- function(
    map,
    lng,
    lat,
    values,
    shape,
    color,
    fillColor = color,
    opacity = 1,
    fillOpacity = opacity,
    strokeWidth = 1,
    width = 20,
    height = width,
    dashArray = NULL,
    label = NULL,
    data = leaflet::getMapData(map),
    ...
) {
  if ( missing(shape) ) {
    shape <- availableShapes()[['default']]
  }
  if ( !missing(values) ) {
    values <- as.factor(parseValues(values, data))
    if ( length(levels(values)) > length(shape) ) {
      stop('values has more factor levels than shape. Maximum levels is 7')
    }
    shape <- shape[values]
  } else {
    shape <- shape[1]
  }
  color <- parseValues(color, data)
  fillColor <- parseValues(fillColor, data)
  label <- parseValues(label, data)
  if ( is.null(dashArray) ) {
    dashArray <- 'none'
  }
  args <- list(shape = shape, color = color,
               fillColor = fillColor, opacity = opacity,
               fillOpacity = fillOpacity,
               strokeWidth = strokeWidth, width = width,
               height = width,
               `stroke-dasharray` = dashArray)
  if (!is.null(label)) {
    args <- append(args, list(label = label))
  }
  iconSymbols <- do.call(makeSymbolIcons, args)
  if (!missing(lng) && !missing(lat)) {
    leaflet::addMarkers(map = map, lng = lng, lat = lat, icon = iconSymbols,
      data = data, ...)
  } else {
    leaflet::addMarkers(map = map, icon = iconSymbols, data = data, ...)
  }
}
#' @export
#'
#' @rdname mapSymbols
addSymbolsSize <- function(
    map,
    lng,
    lat,
    values,
    shape,
    color,
    fillColor = color,
    opacity = 1,
    fillOpacity = opacity,
    strokeWidth = 1,
    baseSize = 20,
    minSize = NULL,
    maxSize = NULL,
    data = leaflet::getMapData(map),
    ...
) {
  values <- parseValues(values, data)
  sizes <- sizeNumeric(values, baseSize, minSize = minSize, maxSize = maxSize)
  color <- parseValues(color, data)
  fillColor <- parseValues(fillColor, data)
  if (!missing(lng) && !missing(lat)) {
    addSymbols(map = map,  lng = lng, lat = lat, shape = shape, color = color,
      fillColor = fillColor, opacity = opacity,
      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, ...)
  }
}
#' @export
#'
#' @rdname mapSymbols
addText <- function(
    map,
    lng,
    lat,
    text,
    color = 'black',
    fillColor = color,
    opacity = 1,
    fillOpacity = opacity,
    strokeWidth = 0,
    width = 20,
    height = width,
    data = leaflet::getMapData(map),
    ...
) {
  text <- parseValues(text, data)
  if ( inherits(color, 'formula') ) {
    color <- parseValues(color, data)
  }
  if ( inherits(fillColor, 'formula') ) {
    fillColor <- parseValues(fillColor, data)
  }
  iconSymbols <- makeSymbolTextIcons(text = text, color = color,
                                     fillColor = fillColor, opacity = opacity,
                                     fillOpacity = fillOpacity,
                                     strokeWidth = strokeWidth, width = width,
                                     height = height)
  if (!missing(lng) && !missing(lat)) {
    leaflet::addMarkers(map = map, lng = lng, lat = lat, icon = iconSymbols,
      data = data, ...)
  } else {
    leaflet::addMarkers(map = map, icon = iconSymbols, data = data, ...)
  }
}
#' @export
#'
#' @rdname mapSymbols
addTextSize <- function(
    map,
    lng,
    lat,
    values,
    text,
    color = 'black',
    fillColor = color,
    opacity = 1,
    fillOpacity = opacity,
    strokeWidth = 0,
    baseSize = 20,
    data = leaflet::getMapData(map),
    ...
) {
  values <- parseValues(values, data)
  sizes <- sizeNumeric(values, baseSize)
  if ( inherits(color, 'formula') ) {
    color <- parseValues(color, data)
  }
  if ( inherits(fillColor, 'formula') ) {
    fillColor <- parseValues(fillColor, data)
  }
  if (!missing(lng) && !missing(lat)) {
    addText(map = map, lng = lng, lat = lat, text = text, color = color,
      fillColor = fillColor, opacity = opacity, fillOpacity = fillOpacity,
      strokeWidth = strokeWidth, width = sizes, data = data, ...)
  } else {
    addText(map = map, text = text, color = color, fillColor = fillColor,
      opacity = opacity, fillOpacity = fillOpacity, strokeWidth = strokeWidth,
      width = sizes, data = data, ...)
  }
}

#' Add Customizable Color Legends to a 'leaflet' map widget
#'
#' Functions for more control over the styling of 'leaflet' legends.
#' The 'leaflet'
#' map is passed through and the output is a 'leaflet' control so that
#' the legends are integrated with other functionality of the API. Style
#' the text of the labels, the symbols used, orientation of the legend items,
#' and sizing of all elements.
#'
#' @param map
#'
#' a map widget object created from 'leaflet'
#'
#' @param pal
#'
#' the color palette function, generated from \link[leaflet]{colorNumeric}
#'
#' @param values
#'
#' the values used to generate colors from the palette function
#'
#' @param bins
#'
#' an approximate number of tick-marks on the color gradient for the
#' colorNumeric palette if it is of length one; you can also provide a
#' numeric vector as the pre-defined breaks
#'
#' @param title
#'
#' the legend title, pass in HTML to style
#'
#' @param shape
#'
#' the desired shape of the symbol, See \link[leaflegend]{availableShapes}
#'
#' @param orientation
#'
#' stack the legend items vertically or horizontally
#'
#' @param width
#'
#' in pixels
#'
#' @param height
#'
#' in pixels
#'
#' @param numberFormat
#'
#' formatting functions for numbers that are displayed e.g. format, prettyNum
#'
#' @param labelStyle
#'
#' character string of style argument for HTML text
#'
#' @param tickLength
#'
#' in pixels
#'
#' @param tickWidth
#'
#' in pixels
#'
#' @param decreasing
#'
#' order of numbers in the legend
#'
#' @param opacity
#'
#' opacity of the legend items
#'
#' @param fillOpacity
#'
#' fill opacity of the legend items
#'
#' @param group
#'
#' group name of a leaflet layer group
#'
#' @param labels
#'
#' labels
#'
#' @param naLabel
#'
#' the legend label for NAs in values
#'
#' @param className
#'
#' extra CSS class to append to the control, space separated
#'
#' @param data a data object. Currently supported objects are matrices, data
#'   frames, spatial objects from the \pkg{sp} package
#'   (\code{SpatialPoints}, \code{SpatialPointsDataFrame}, \code{Polygon},
#'   \code{Polygons}, \code{SpatialPolygons}, \code{SpatialPolygonsDataFrame},
#'   \code{Line}, \code{Lines}, \code{SpatialLines}, and
#'   \code{SpatialLinesDataFrame}), and
#'   spatial data frames from the \pkg{sf} package.
#'
#' @param ...
#'
#' arguments to pass to \link[leaflet]{addControl} for addLegendNumeric,
#' addLegendQuantile, addLegendBin, and addLegendFactor
#'
#' @export
#'
#' @return
#'
#' an object from \link[leaflet]{addControl}
#'
#' @name addLeafLegends
#'
#' @examples
#' library(leaflet)
#'
#' data(quakes)
#'
#' # Numeric Legend
#'
#' numPal <- colorNumeric('viridis', quakes$depth)
#' leaflet() %>%
#'   addTiles() %>%
#'   addLegendNumeric(
#'     pal = numPal,
#'     values = quakes$depth,
#'     position = 'topright',
#'     title = 'addLegendNumeric (Horizontal)',
#'     orientation = 'horizontal',
#'     shape = 'rect',
#'     decreasing = FALSE,
#'     bins = 5,
#'     height = 20,
#'     width = 150
#'   ) %>%
#'   addLegendNumeric(
#'     pal = numPal,
#'     values = quakes$depth,
#'     position = 'topright',
#'     title = htmltools::tags$div('addLegendNumeric (Decreasing)',
#'     style = 'font-size: 24px; text-align: center; margin-bottom: 5px;'),
#'     orientation = 'vertical',
#'     shape = 'stadium',
#'     decreasing = TRUE,
#'     height = 100,
#'     width = 20
#'   ) %>%
#'   addLegend(pal = numPal, values = quakes$depth, title = 'addLegend')
#'
#' # Quantile Legend
#' # defaults to adding quantile numeric break points
#'
#' quantPal <- colorQuantile('viridis', quakes$mag, n = 5)
#' leaflet() %>%
#'   addTiles() %>%
#'   addCircleMarkers(data = quakes,
#'                    lat = ~lat,
#'                    lng = ~long,
#'                    color = ~quantPal(mag),
#'                    opacity = 1,
#'                    fillOpacity = 1
#'   ) %>%
#'   addLegendQuantile(pal = quantPal,
#'                     values = quakes$mag,
#'                     position = 'topright',
#'                     title = 'addLegendQuantile',
#'                     numberFormat = function(x) {prettyNum(x, big.mark = ',',
#'                     scientific = FALSE, digits = 2)},
#'                     shape = 'circle') %>%
#'   addLegendQuantile(pal = quantPal,
#'                     values = quakes$mag,
#'                     position = 'topright',
#'                     title = htmltools::tags$div('addLegendQuantile',
#'                                                 htmltools::tags$br(),
#'                                                 '(Omit Numbers)'),
#'                     numberFormat = NULL,
#'                     shape = 'circle') %>%
#'   addLegend(pal = quantPal, values = quakes$mag, title = 'addLegend')
#'
#' # Factor Legend
#' # Style the title with html tags, several shapes are supported drawn with svg
#'
#' quakes[['group']] <- sample(c('A', 'B', 'C'), nrow(quakes), replace = TRUE)
#' factorPal <- colorFactor('Dark2', quakes$group)
#' leaflet() %>%
#'   addTiles() %>%
#'   addCircleMarkers(
#'     data = quakes,
#'     lat = ~ lat,
#'     lng = ~ long,
#'     color = ~ factorPal(group),
#'     opacity = 1,
#'     fillOpacity = 1
#'   ) %>%
#'   addLegendFactor(
#'     pal = factorPal,
#'     title = htmltools::tags$div('addLegendFactor', style = 'font-size: 24px;
#'     color: red;'),
#'     values = quakes$group,
#'     position = 'topright',
#'     shape = 'triangle',
#'     width = 50,
#'     height = 50
#'   ) %>%
#'   addLegend(pal = factorPal,
#'             values = quakes$group,
#'             title = 'addLegend')
#'
#' # Bin Legend
#' # Restyle the text of the labels, change the legend item orientation
#'
#' binPal <- colorBin('Set1', quakes$mag)
#' leaflet(quakes) %>%
#'   addTiles() %>%
#'   addCircleMarkers(
#'     lat = ~ lat,
#'     lng = ~ long,
#'     color = ~ binPal(mag),
#'     opacity = 1,
#'     fillOpacity = 1
#'   ) %>%
#'   addLegendBin(
#'     pal = binPal,
#'     position = 'topright',
#'     values = ~mag,
#'     title = 'addLegendBin',
#'     labelStyle = 'font-size: 18px; font-weight: bold;',
#'     orientation = 'horizontal'
#'   ) %>%
#'   addLegend(pal = binPal,
#'             values = quakes$mag,
#'             title = 'addLegend')
#'
#' # Group Layer Control
#' # Works with baseGroups and overlayGroups
#'
#' leaflet() %>%
#'   addTiles() %>%
#'   addLegendNumeric(
#'     pal = numPal,
#'     values = quakes$depth,
#'     position = 'topright',
#'     title = 'addLegendNumeric',
#'     group = 'Numeric Data'
#'   ) %>%
#'   addLegendQuantile(
#'     pal = quantPal,
#'     values = quakes$mag,
#'     position = 'topright',
#'     title = 'addLegendQuantile',
#'     group = 'Quantile'
#'   ) %>%
#'   addLegendBin(
#'     data = quakes,
#'     pal = binPal,
#'     position = 'bottomleft',
#'     title = 'addLegendBin',
#'     group = 'Bin',
#'     values = ~mag
#'   ) %>%
#'   addLayersControl(
#'     baseGroups = c('Numeric Data', 'Quantile'),  overlayGroups = c('Bin'),
#'     position = 'bottomright'
#'   )
addLegendNumeric <- function(map,
                             pal,
                             values,
                             title = NULL,
                             shape = c('rect', 'stadium'),
                             orientation = c('vertical', 'horizontal'),
                             width = 20,
                             height = 100,
                             bins = 7,
                             numberFormat = function(x) {
                               prettyNum(x, format = 'f', big.mark = ',',
                                         digits = 3, scientific = FALSE)
                               },
                             tickLength = 4,
                             tickWidth = 1,
                             decreasing = FALSE,
                             fillOpacity = 1,
                             group = NULL,
                             labels = NULL,
                             naLabel = 'NA',
                             labelStyle = '',
                             className = 'info legend leaflet-control',
                             data = leaflet::getMapData(map),
                             ...) {
  stopifnot(is.logical(decreasing))
  stopifnot(attr(pal, 'colorType') == 'numeric')
  stopifnot(is.numeric(width) && is.numeric(height) && width >= 0 &&
               height >= 0)
  stopifnot(is.numeric(tickLength) && is.numeric(tickWidth) &&
               tickLength >= 0 && tickWidth >= 0)
  shape <- match.arg(shape)
  id <- sprintf('gradient-%s-%d',
                gsub('[[:punct:]]|\\s', '', deparse(match.call()[['values']])),
                length(map[["x"]][["calls"]]) + 1)
  values <- parseValues(values = values, data = data)
  rng <- range(values, na.rm = TRUE)
  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]
  }
  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 {
    stdBreaks <- (breaks - rng[1]) / diff(rng) *
      (height * isVertical + width * isHorizontal)
  }
  if (isVertical) {
    # makeTicks/makeTickText place vertical positions at height - breaks
    stdBreaks <- height - stdBreaks
  }
  if (length(breaks) > 2) {
    i <- seq(2L, length(breaks) - 1L, 1L)
  } else {
    i <- c(1, length(breaks))
  }
  if (is.null(labels)) {
    labels <- numberFormat(breaks)[i]
  } else if (decreasing) {
    # user labels pair with bins in ascending order; match reversed breaks
    labels <- rev(labels)
  }
  ticks <- makeTicks(breaks = stdBreaks[i], width = tickLength,
    height = height, strokeWidth = tickWidth, stroke = 'black', transform =
      sprintf('translate(%.03f,%.03f)', width * isVertical,
        height * isHorizontal),
    orientation = orientation)
  tickText <- makeTickText(labels =  labels, breaks = stdBreaks[i],
    width = width, height = height, orientation = orientation)
  svgGradient <- makeGradient(breaks = offsets,
    pal = pal,height = height, width = width, id = id,
    fillOpacity = fillOpacity, orientation = orientation, shape)
  hasHorizontalTickLabels <- isHorizontal && length(labels) > 2
  htmlElements <- assembleLegendWithTicks(
    width = width + (isVertical * tickLength * 2),
    height = height + (isHorizontal * tickLength * 2),
    svgElements = svgGradient, ticks = ticks, tickText = tickText,
    labelStyle = labelStyle,
    marginLeft = ifelse(hasHorizontalTickLabels,
                        nchar(labels[1]) * .25, 0),
    marginRight = ifelse(isVertical, max(nchar(labels)) * .5,
                  ifelse(hasHorizontalTickLabels,
                         nchar(labels[length(labels)]) * .25, 0)),
    marginBottom = ifelse(isHorizontal, 1, 0))
  naSize <- width * isVertical + height * isHorizontal
  htmlElements <- addNa(hasNa = hasNa, htmlElements = htmlElements,
    shape = shape, labels = naLabel, colors = pal(NA), labelStyle = labelStyle,
    height = naSize, width = naSize, opacity = fillOpacity,
    fillOpacity = fillOpacity, strokeWidth = 0)
  htmlElements <- addTitle(title = title, htmlElements = list(htmlElements))
  leaflegendAddControl(map, html = htmlElements, className = className,
    group = group, ...)
}

makeGradient <- function(breaks, pal, height, width, id, fillOpacity,
  orientation, shape) {
  stops <- (breaks - breaks[1]) /
    (breaks[length(breaks)] - breaks[1])
  colors <- pal(breaks)
  offsets <- sprintf('%.03f%%', 100 * stops)
  curvePercent <- ifelse(shape == 'stadium', '10%', '0')
  if (orientation == 'vertical') {
    htmltools::tagList(
      htmltools::tags$defs(
        htmltools::tags$linearGradient(
          id = id,
          x1 = 0, y1 = 0, x2 = 0, y2 = 1,
          htmltools::tagList(Map(htmltools::tags$stop,
            offset = offsets,
            'stop-color' = colors))
        )
      ),
      htmltools::tags$g(
        htmltools::tags$rect(height = height, width = width, x = 0,
          rx = curvePercent, 'fill-opacity' = fillOpacity,
          fill = sprintf('url(#%s)', id))
      )
    )
  } else {
    htmltools::tagList(
      htmltools::tags$defs(
        htmltools::tags$linearGradient(
          id = id,
          x1 = 0, y1 = 0, x2 = 1, y2 = 0,
          htmltools::tagList(Map(htmltools::tags$stop,
            offset = offsets,
            'stop-color' = colors))
        )
      ),
      htmltools::tags$g(
        htmltools::tags$rect(height = height, width = width, x = 0,
          ry = curvePercent, 'fill-opacity' = fillOpacity,
          fill = sprintf('url(#%s)', id))
      )
    )
  }
}

makeTicks <- function(breaks, width, height, strokeWidth, orientation, ...) {
  if (orientation == 'vertical') {
    tickLocations <- height - breaks
    ticks <- Map(htmltools::tags$line, x1 = 0,
      x2 = width, y1 = tickLocations, y2 = tickLocations,
      `stroke-width` = strokeWidth,
      ...)
  } else {
    tickLocations <- breaks
    ticks <- Map(htmltools::tags$line, x1 = tickLocations, x2 = tickLocations,
      y1 = 0, y2 = width, `stroke-width` = strokeWidth, ...)
  }
  ticks
}
makeTickText <- function(labels, breaks, width, height, orientation) {
  if (orientation == 'vertical') {
    tickLocations <- height - breaks
    Map(
      htmltools::p,
      labels,
      style = sprintf('position: absolute; margin: 0; top: calc(%.2fpx - .5em);
        right: 0; line-height:1;',
        tickLocations)
    )
  } else if (length(labels) > 2) {
    tickLocations <- breaks
    halfWidthEm <- nchar(labels) * .25
    Map(
      htmltools::p,
      labels,
      style = sprintf(
        'position: absolute; margin: 0; left: calc(%.2fpx + 1px - %sem); bottom: 0;
        white-space: nowrap; line-height:1;',
        tickLocations, halfWidthEm)
    )
  } else {
    Map(
      htmltools::p,
      labels,
      style = sprintf('position: absolute; margin: 0; %s: 0; bottom: 0;
        line-height:1;',
        c('left', 'right'))
    )
  }

}
assembleLegendWithTicks <- function(width, height, svgElements, ticks, tickText,
  labelStyle, marginRight, marginBottom, marginLeft = 0) {
  htmlElements <- htmltools::tags$svg(
    xmlns = "http://www.w3.org/2000/svg",
    version = "1.1",
    width = width,
    height = height,
    htmltools::tagList(svgElements, ticks)
  )
  htmlElements <- htmltools::tags$img(src = makeSvgUri(htmlElements,
    width = width, height = height, strokeWidth = 0),
    style = 'margin-left: 1px;')
  if (marginLeft > 0) {
    inner <- htmltools::tags$div(
      style = sprintf(
        'position: relative; width: calc(%spx + 2px); height: calc(%spx + %sem);',
        width, height, marginBottom),
      htmlElements,
      tickText
    )
    htmltools::tags$div(
      style = sprintf(
        'display: inline-block; margin-top:.5em; margin-bottom:.5em; %s;
        padding-left:%sem; padding-right:%sem;',
        labelStyle, marginLeft, marginRight),
      inner
    )
  } else {
    htmltools::tags$div(
      style = sprintf(
        'position: relative; margin-top:.5em; margin-bottom:.5em; %s;
      width: calc(%spx + %sem + 2px); height: calc(%spx + %sem);',
        labelStyle, width, marginRight, height, marginBottom),
      htmlElements,
      tickText
    )
  }
}

addTitle <- function(title, htmlElements) {
  if (is.null(title)) {
    NULL
  } else if (inherits(title, 'shiny.tag')) {
    title <- list(htmltools::div(title))
  } else if (is.character(title)) {
    title <- list(htmltools::div(htmltools::tags$strong(title)))
  } else {
    stop('Title must be character vector or an html tags object')
  }
  htmltools::tagList(title, htmlElements)
}

#' @export
#'
#' @rdname addLeafLegends
#'
addLegendQuantile <- function(map,
                              pal,
                              values,
                              title = NULL,
                              labelStyle = '',
                              shape = 'rect',
                              orientation = c('vertical', 'horizontal'),
                              width = 24,
                              height = 24,
                              numberFormat = function(x) {
                                prettyNum(x, big.mark = ',', scientific = FALSE,
                                          digits = 1)
                                },
                              opacity = 1,
                              fillOpacity = opacity,
                              group = NULL,
                              className = 'info legend leaflet-control',
                              naLabel = 'NA',
                              between = ' - ',
                              data = leaflet::getMapData(map),
                              ...) {
  stopifnot( attr(pal, 'colorType') == 'quantile' )
  stopifnot( width >= 0 && height >= 0 )
  orientation <- match.arg(orientation)
  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,
                      probs[-1] * 100)
  } else {
    breaks <- stats::quantile(x = values, probs = probs, na.rm = TRUE)
    labels <- numberFormat(breaks)
    labels <- sprintf('%3.0f%%%s%3.0f%% (%s%s%s)',
                    probs[-length(probs)] * 100,
                    between,
                    probs[-1] * 100,
                    labels[-length(labels)],
                    between,
                    labels[-1])
  }
  colors <- unique(pal(sort(values)))
  htmlElements <- makeLegendCategorical(shape = shape, labels = labels,
    colors = colors,
    labelStyle = labelStyle,
    height = height, width = width,
    opacity = opacity,
    fillOpacity = fillOpacity,
    orientation = orientation,
    title = title,
    hasNa = any(is.na(values)),
    naLabel = naLabel,
    naColor = pal(NA))
  leaflegendAddControl(map, html = htmltools::tagList(htmlElements),
                       className = className, group = group, ...)
}

#' @param between
#'
#' a separator between legend range labels
#'
#' @param labelCutpoints
#'
#' if \code{TRUE}, labels are placed at bin boundaries (cutpoints) with tick
#' marks instead of beside each symbol. Only supported for vertical
#' orientation.
#'
#' @param tickLength
#'
#' length of tick marks in pixels, used when \code{labelCutpoints = TRUE}
#'
#' @param tickWidth
#'
#' stroke width of tick marks in pixels, used when \code{labelCutpoints = TRUE}
#'
#' @export
#'
#' @rdname addLeafLegends
#'
addLegendBin <- function(map,
                         pal,
                         values,
                         title = NULL,
                         labelStyle = '',
                         shape = 'rect',
                         orientation = c('vertical', 'horizontal'),
                         width = 24,
                         height = 24,
                         numberFormat = function(x) {
                           format(round(x, 3), big.mark = ',', trim = TRUE,
                                  scientific = FALSE)
                         },
                         opacity = 1,
                         fillOpacity = opacity,
                         group = NULL,
                         className = 'info legend leaflet-control',
                         naLabel = 'NA',
                         between = ' - ',
                         labelCutpoints = FALSE,
                         tickLength = 4,
                         tickWidth = 1,
                         data = leaflet::getMapData(map),
                         ...) {
  stopifnot( attr(pal, 'colorType') == 'bin' )
  stopifnot( width >= 0 && height >= 0 )
  orientation <- match.arg(orientation)
  if (isTRUE(labelCutpoints) && orientation == 'horizontal')
    stop('labelCutpoints = TRUE is only supported for vertical orientation.')
  values <- parseValues(values = values, data = data)
  bins <- attr(pal, 'colorArgs')[['bins']]
  colors <- pal((bins[-1] + bins[-length(bins)]) / 2 )
  if (isTRUE(labelCutpoints)) {
    htmlElements <- makeLegendBinTicks(
      bins = bins,
      colors = colors,
      shape = shape,
      width = width,
      height = height,
      tickLength = tickLength,
      tickWidth = tickWidth,
      numberFormat = numberFormat,
      labelStyle = labelStyle,
      fillOpacity = fillOpacity,
      title = title,
      hasNa = any(is.na(values)),
      naLabel = naLabel,
      naColor = pal(NA)
    )
  } else {
    labels <- sprintf(' %s%s%s', numberFormat(bins[-length(bins)]), between,
                      numberFormat(bins[-1]))
    htmlElements <- makeLegendCategorical(shape = shape, labels = labels,
      colors = colors,
      labelStyle = labelStyle,
      height = height, width = width,
      opacity = opacity,
      fillOpacity = fillOpacity,
      orientation = orientation,
      title = title,
      hasNa = any(is.na(values)),
      naLabel = naLabel,
      naColor = pal(NA))
  }
  leaflegendAddControl(map, html = htmltools::tagList(htmlElements),
                       className = className, group = group, ...)
}

#' @export
#'
#' @rdname addLeafLegends
#'
addLegendFactor <- function(map,
                            pal,
                            values,
                            title = NULL,
                            labelStyle = '',
                            shape = 'rect',
                            orientation = c('vertical', 'horizontal'),
                            width = 24,
                            height = 24,
                            opacity = 1,
                            fillOpacity = opacity,
                            group = NULL,
                            className = 'info legend leaflet-control',
                            naLabel = 'NA',
                            data = leaflet::getMapData(map),
                            ...) {
  stopifnot( attr(pal, 'colorType') == 'factor' )
  stopifnot( width >= 0 && height >= 0 )
  orientation <- match.arg(orientation)
  values <- parseValues(values = values, data = data)
  hasNa <- any(is.na(values))
  values <- sort(unique(values))
  labels <- sprintf(' %s', values)
  colors <- pal(values)
  htmlElements <- makeLegendCategorical(shape = shape, labels = labels,
                                        colors = colors,
                                        labelStyle = labelStyle,
                                        height = height, width = width,
                                        opacity = opacity,
                                        fillOpacity = fillOpacity,
                                        orientation = orientation,
                                        title = title,
                                        hasNa = hasNa,
                                        naLabel = naLabel,
                                        naColor = pal(NA))
  leaflegendAddControl(map, html = htmltools::tagList(htmlElements),
                       className = className, group = group, ...)
}

makeLegendCategorical <- function(shape, labels, colors, labelStyle, height,
                              width, opacity, fillOpacity, orientation, title,
  hasNa, naLabel, naColor) {
  htmlElements <- Map(
    f = makeLegendSymbol,
    shape = shape,
    label = labels,
    color = colors,
    labelStyle = labelStyle,
    height = height,
    width = width,
    opacity = opacity,
    fillOpacity = fillOpacity,
    'stroke-width' = 1
  )
  if ( orientation == 'vertical' ) {
    htmlElements <- lapply(htmlElements, htmltools::tagList,
                           htmltools::tags$br())
  }
  htmlElements <- addTitle(title = title, htmlElements = htmlElements)
  htmlElements <- addNa(hasNa = hasNa, htmlElements = htmlElements,
    shape = shape, labels = naLabel, colors = naColor, labelStyle = labelStyle,
    height = height, width = width, opacity = fillOpacity,
    fillOpacity = fillOpacity, strokeWidth = 1)
  htmlElements
}

makeLegendBinTicks <- function(bins, colors, shape, width, height, tickLength,
  tickWidth, numberFormat, labelStyle, fillOpacity, title, hasNa, naLabel,
  naColor) {
  nBins <- length(colors)
  totalHeight <- nBins * height
  pad <- ceiling(tickWidth / 2)
  svgHeight <- totalHeight + 2 * pad
  # breaks run high-to-low so tickLocations = svgHeight - breaks maps to
  # y = pad (top boundary) through y = totalHeight + pad (bottom boundary)
  stdBreaks <- seq(totalHeight + pad, pad, by = -height)
  tickLabels <- numberFormat(bins)
  shapeElements <- Map(
    f = makeSymbolElement,
    color = colors,
    fillColor = colors,
    shape = shape, width = width, height = height,
    fillOpacity = fillOpacity, 'stroke-width' = 0
  )
  transforms <- sprintf('translate(0,%g)', pad + seq(0, by = height,
    length.out = nBins))
  shapeElements <- Map(htmltools::tags$g, shapeElements,
    transform = transforms)
  ticks <- makeTicks(breaks = stdBreaks, width = tickLength,
    height = svgHeight, strokeWidth = tickWidth, stroke = 'black',
    transform = sprintf('translate(%.03f,0)', width),
    orientation = 'vertical')
  tickText <- makeTickText(labels = tickLabels, breaks = stdBreaks,
    width = width, height = svgHeight, orientation = 'vertical')
  htmlElements <- assembleLegendWithTicks(
    width = width + tickLength * 2,
    height = svgHeight,
    svgElements = shapeElements,
    ticks = ticks,
    tickText = tickText,
    labelStyle = labelStyle,
    marginRight = max(nchar(tickLabels)) * .5,
    marginBottom = 0
  )
  htmlElements <- addTitle(title = title, htmlElements = list(htmlElements))
  htmlElements <- addNa(hasNa = hasNa, htmlElements = htmlElements,
    shape = shape, labels = naLabel, colors = naColor,
    labelStyle = labelStyle, height = width, width = width,
    opacity = fillOpacity, fillOpacity = fillOpacity, strokeWidth = 0)  
  htmlElements
}

addNa <- function(hasNa, htmlElements, shape, labels, colors,
  labelStyle, height,  width, opacity, fillOpacity, strokeWidth) {
  if (hasNa) {
    naLegend <- list(htmltools::div(
      #style = 'margin-top: .3rem;',
      makeLegendSymbol(
        shape = shape,
        label = labels,
        color = colors,
        labelStyle = labelStyle,
        height = height,
        width = width,
        opacity = opacity,
        fillOpacity = fillOpacity,
        'stroke-width' = strokeWidth,
        imgStyle = 'vertical-align: middle; margin: 1px;'
      )))
    htmlElements <- htmltools::tagList(htmlElements, naLegend)
  }
  htmlElements
}

#' Add a legend for the sizing of symbols or the width of lines
#'
#' @param map
#'
#' a map widget object created from 'leaflet'
#'
#' @param pal
#'
#' the color palette function, generated from \link[leaflet]{colorNumeric}
#'
#' @param values
#'
#' the values used to generate sizes and if colorValues is not specified and
#' pal is given, then the values are used to generate  colors from the palette
#' function
#'
#' @param title
#'
#' the legend title, pass in HTML to style
#'
#' @param shape
#'
#' the desired shape of the symbol, See \link[leaflegend]{availableShapes}
#'
#' @param orientation
#'
#' stack the legend items vertically or horizontally
#'
#'
#' @param labelStyle
#'
#' character string of style argument for HTML text
#'
#'
#' @param opacity
#'
#' opacity of the legend items
#'
#' @param fillOpacity
#'
#' fill opacity of the legend items
#'
#' @param breaks
#'
#' an integer specifying the number of breaks or a numeric vector of the breaks.
#' if a named vector is given, the names are used as labels
#'
#' @param baseSize
#'
#' re-scaling size in pixels of the mean of the values, the average value will
#' be this exact size
#'
#' @param minSize
#'
#' minimum size in pixels of a symbol; values that would scale below this are
#' clamped to \code{minSize}; \code{baseSize} must be greater than \code{minSize}
#'
#' @param maxSize
#'
#' maximum size in pixels of a symbol; values that would scale above this are
#' clamped to \code{maxSize}; \code{baseSize} must be less than \code{maxSize}
#'
#' @param color
#'
#' the color of the legend symbols, if omitted pal is used
#'
#' @param fillColor
#'
#' fill color of symbol
#'
#' @param strokeWidth
#'
#' width of symbol outline
#'
#' @param numberFormat
#'
#' formatting functions for numbers that are displayed e.g. format, prettyNum
#'
#' @param group
#'
#' group name of a leaflet layer group
#'
#' @param className
#'
#' extra CSS class to append to the control, space separated
#'
#' @param stacked
#'
#' If \code{TRUE}, symbols are overlayed onto each other for a more compact
#' size legend
#'
#' @param data a data object. Currently supported objects are matrices, data
#'   frames, spatial objects from the \pkg{sp} package
#'   (\code{SpatialPoints}, \code{SpatialPointsDataFrame}, \code{Polygon},
#'   \code{Polygons}, \code{SpatialPolygons}, \code{SpatialPolygonsDataFrame},
#'   \code{Line}, \code{Lines}, \code{SpatialLines}, and
#'   \code{SpatialLinesDataFrame}), and
#'   spatial data frames from the \pkg{sf} package.
#'
#' @param ...
#'
#' arguments to pass to \link[leaflet]{addControl} for addLegendSize,
#' addLegendLine, addLegendSymbol, addLegendText, and addLegendTextSize
#'
#' @return
#'
#' an object from \link[leaflet]{addControl}
#'
#' @export
#'
#' @name legendSymbols
#'
#' @examples
#' library(leaflet)
#' data("quakes")
#' quakes <- quakes[1:100,]
#' numPal <- colorNumeric('viridis', quakes$depth)
#' sizes <- sizeNumeric(quakes$depth, baseSize = 10)
#' symbols <- Map(
#'   makeSymbol,
#'   shape = 'triangle',
#'   color = numPal(quakes$depth),
#'   width = sizes,
#'   height = sizes
#' )
#' leaflet() %>%
#'   addTiles() %>%
#'   addMarkers(data = quakes,
#'              icon = icons(iconUrl = symbols),
#'              lat = ~lat, lng = ~long) %>%
#'   addLegendSize(
#'     values = quakes$depth,
#'     pal = numPal,
#'     title = 'Depth',
#'     labelStyle = 'margin: auto;',
#'     shape = c('triangle'),
#'     orientation = c('vertical', 'horizontal'),
#'     opacity = .7,
#'     breaks = 5)
#'
#' # a wrapper for making icons is provided
#' sizeSymbols <-
#' makeSymbolsSize(
#'   quakes$depth,
#'   shape = 'cross',
#'   fillColor = numPal(quakes$depth),
#'   color = 'black',
#'   strokeWidth = 1,
#'   opacity = .8,
#'   fillOpacity = .5,
#'   baseSize = 20
#' )
#' leaflet() %>%
#'   addTiles() %>%
#'   addMarkers(data = quakes,
#'              icon = sizeSymbols,
#'              lat = ~lat, lng = ~long) %>%
#'   addLegendSize(
#'     values = quakes$depth,
#'     pal = numPal,
#'     title = 'Depth',
#'     shape = 'cross',
#'     orientation = 'horizontal',
#'     strokeWidth = 1,
#'     opacity = .8,
#'     fillOpacity = .5,
#'     color = 'black',
#'     baseSize = 20,
#'     breaks = 5)
#'
#' # Group layers control
#' leaflet() %>%
#'   addTiles() %>%
#'     addLegendSize(
#'       values = quakes$depth,
#'       pal = numPal,
#'       title = 'Depth',
#'       labelStyle = 'margin: auto;',
#'       shape = c('triangle'),
#'       orientation = c('vertical', 'horizontal'),
#'       opacity = .7,
#'       breaks = 5,
#'       group = 'Depth') %>%
#'     addLayersControl(overlayGroups = c('Depth'))
#'
#' # Polyline Legend for Size
#' baseSize <- 10
#' lineColor <- '#00000080'
#' pal <- colorNumeric('Reds', atlStorms2005$MinPress)
#' leaflet() %>%
#'   addTiles() %>%
#'   addPolylines(data = atlStorms2005,
#'                weight = ~sizeNumeric(values = MaxWind, baseSize = baseSize),
#'                color = ~pal(MinPress),
#'                popup = ~as.character(MaxWind)) %>%
#'   addLegendLine(values = atlStorms2005$MaxWind,
#'                 title = 'MaxWind',
#'                 baseSize = baseSize,
#'                 width = 50,
#'                 color = lineColor) %>%
#'   addLegendNumeric(pal = pal,
#'                    title = 'MinPress',
#'                    values = atlStorms2005$MinPress)
#'
#' # Stacked Legends
#' leaflet(quakes) %>%
#' addTiles() %>%
#'   addSymbolsSize(values = ~10^(mag),
#'     lat = ~lat,
#'     lng = ~long,
#'     shape = 'circle',
#'     color = 'black',
#'     fillColor = 'red',
#'     opacity = 1,
#'     baseSize = 5) %>%
#'   addLegendSize(
#'     values = ~10^(mag),
#'     title = 'Magnitude',
#'     baseSize = 5,
#'     shape = 'circle',
#'     color = 'black',
#'     fillColor = 'red',
#'     labelStyle = 'font-size: 18px;',
#'     position = 'bottomleft',
#'     stacked = TRUE,
#'     breaks = 5)
#'
#' # Text legend (categorical)
#' quakes$grp <- sample(c('A', 'B', 'C'), nrow(quakes), replace = TRUE)
#' grpPal <- colorFactor('Dark2', quakes$grp)
#' leaflet(quakes) %>%
#'   addTiles() %>%
#'   addText(lng = ~long, lat = ~lat, text = ~grp,
#'           color = 'white', fillColor = ~grpPal(grp), width = 20) %>%
#'   addLegendText(pal = grpPal, values = ~grp, title = 'Group',
#'                 labels = c('Group A', 'Group B', 'Group C'),
#'                 position = 'topright', fontFamily = 'sans-serif')
#'
#' # Text size legend (auto-computed font size)
#' leaflet(quakes) %>%
#'   addTiles() %>%
#'   addTextSize(lng = ~long, lat = ~lat,
#'               text = ~as.character(round(mag, 1)),
#'               values = ~mag, color = 'black', fillColor = 'yellow',
#'               baseSize = 30) %>%
#'   addLegendTextSize(pal = colorNumeric('viridis', quakes$mag),
#'                     values = ~mag, text = 'M', title = 'Magnitude',
#'                     baseSize = 30, breaks = 5,
#'                     position = 'bottomright')
#'     # dashed lines
#' leaflet() %>%
#'    addTiles() %>%
#'    addLegendSymbol(color='black', dashArray = list("none", "24"),
#'      shape = c("line", "line"), values = c('solid', 'dashed'),
#'      strokeWidth = 10, height = 20, width = 100)
#'
#' #advanced shape customization, aesthetic arguments are propogated if
#' # vectors are equal length or of size 1
#' defaultShapes <- availableShapes()[["default"]]
#' leaflet() %>%
#'   addTiles() %>%
#'   addLegendSymbol(
#'     shape = defaultShapes,
#'     color = "black",
#'     fillColor =
#'       colorRampPalette(c("blue",  "yellow"))(length(defaultShapes)),
#'     width = seq(1L, length(defaultShapes), 1L) * length(defaultShapes),
#'     values = factor(defaultShapes, defaultShapes),
#'     strokeWidth = 2
#'   )
#'
#' # label centered inside each legend symbol
#' leaflet() %>%
#'   addTiles() %>%
#'   addLegendSymbol(
#'     shape = c('circle', 'circle', 'circle'),
#'     color = 'black',
#'     fillColor = c('red', 'blue', 'green'),
#'     fillOpacity = 0.8,
#'     values = c('A', 'B', 'C'),
#'     label = c('A', 'B', 'C'),
#'     width = 24
#'   )
addLegendSize <- function(map,
                          pal,
                          values,
                          title = NULL,
                          labelStyle = 'vertical-align: middle;',
                          shape = 'rect',
                          orientation = c('vertical', 'horizontal'),
                          color,
                          fillColor = color,
                          strokeWidth = 1,
                          opacity = 1,
                          fillOpacity = opacity,
                          breaks = 5,
                          baseSize = 20,
                          minSize = NULL,
                          maxSize = NULL,
                          numberFormat = function(x) {
                            prettyNum(x, big.mark = ',', scientific = FALSE,
                                      digits = 1)
                            },
                          group = NULL,
                          className = 'info legend leaflet-control',
                          stacked = FALSE,
                          data = leaflet::getMapData(map),
                          ...) {
  values <- parseValues(values = values, data = data)
  sizes <- sizeBreaks(values, breaks, baseSize, minSize = minSize, maxSize = maxSize)
  if ( missing(color) ) {
    stopifnot( missing(color) & !missing(pal))
    colors <- pal(as.numeric(names(sizes)))
  } else {
    stopifnot(length(color) == 1 || length(color) == length(breaks))
    colors <- color
  }
  if ( missing(fillColor) ) {
    if ( !missing(pal) ) {
      fillColors <- pal(as.numeric(names(sizes)))
    } else {
      fillColors <- colors
    }
  } else {
    stopifnot(length(fillColor) == 1 || length(fillColor) == length(breaks))
    fillColors <- fillColor
  }
  labels <- numberFormat(as.numeric(names(sizes)))
  if (length(names(breaks)) == length(breaks) && length(breaks) > 1) {
    labels <- names(breaks)
  }
  symbols <- Map(makeSymbol,
                 shape = shape,
                 width = sizes,
                 height = sizes,
                 color = colors,
                 fillColor = fillColors,
                 opacity = opacity,
                 fillOpacity = fillOpacity,
                 `stroke-width` = strokeWidth)
  if (isTRUE(stacked)) {
    stackedMax <- max(sizes)
    svgElements <- rev(Map(makeSymbolElement,
      shape = shape,
      width = sizes,
      height = sizes,
      color = colors,
      fillColor = fillColors,
      opacity = opacity,
      fillOpacity = fillOpacity,
      `stroke-width` = strokeWidth,
      transform = sprintf('translate(%.02f,%.02f)', stackedMax / 2 - sizes / 2,
        stackedMax - sizes)))
    ticks <- makeTicks(breaks = sizes - strokeWidth,
      width = stackedMax / 2 + strokeWidth, height = stackedMax,
      orientation = 'vertical', strokeWidth = strokeWidth,
      `stroke-linecap` = 'square', stroke = 'black',
      transform = sprintf('translate(%.03f,0)',
        stackedMax / 2 + strokeWidth * 3 / 2))
    tickText <- makeTickText(labels = labels, breaks = sizes - strokeWidth,
      width = stackedMax, height = stackedMax, orientation = 'vertical')
    htmlElements <- assembleLegendWithTicks(width = stackedMax + strokeWidth * 2,
      height = stackedMax + strokeWidth * 2, svgElements = svgElements,
      ticks = ticks, tickText = tickText, labelStyle = labelStyle,
      marginRight = .5 * max(nchar(labels)),
      marginBottom = 0)
    htmlElements <- htmltools::tagList(title, htmlElements = htmlElements)
    leaflegendAddControl(map, html = htmltools::tagList(htmlElements),
      className = className, group = group, ...)
  } else {
    addLegendImage(map, images = symbols,
                   labels = labels,
                   title = title, labelStyle = labelStyle,
                   orientation = orientation, width = sizes, height = sizes,
                   group = group, className = className, ...)
  }

}

#' @param minSize
#'
#' minimum size in pixels of a symbol; values that would scale below this are
#' clamped to \code{minSize}; \code{baseSize} must be greater than \code{minSize}
#'
#' @param maxSize
#'
#' maximum size in pixels of a symbol; values that would scale above this are
#' clamped to \code{maxSize}; \code{baseSize} must be less than \code{maxSize}
#'
#' @param centerPoint
#'
#' the value used as the center of the scaling; defaults to the mean of
#' \code{values}; the symbol for \code{centerPoint} will be exactly
#' \code{baseSize} pixels
#'
#' @export
#'
#' @rdname mapSymbols
sizeNumeric <- function(values, baseSize, minSize = NULL, maxSize = NULL,
  centerPoint = mean(values, na.rm = TRUE)) {
  stopifnot(baseSize > 0)
  if ( !is.null(minSize) ) {
    stopifnot(minSize > 0)
    stopifnot(baseSize > minSize)
  }
  if ( !is.null(maxSize) ) {
    stopifnot(maxSize > 0)
    stopifnot(baseSize < maxSize)
  }
  if ( !is.null(minSize) && !is.null(maxSize) ) {
    stopifnot(minSize < maxSize)
  }
  sizes <- values / centerPoint * baseSize
  if ( !is.null(minSize) ) {
    sizes <- pmax(sizes, minSize)
  }
  if ( !is.null(maxSize) ) {
    sizes <- pmin(sizes, maxSize)
  }
  sizes
}

#' @param breaks
#'
#' an integer specifying the number of breaks or a numeric vector of the breaks;
#' if a named vector then the names are used as labels.
#'
#' @param baseSize
#'
#' re-scaling size in pixels of the mean of the values, the average value will
#' be this exact size
#'
#' @export
#'
#' @rdname mapSymbols
sizeBreaks <- function(values, breaks, baseSize, minSize = NULL, maxSize = NULL, 
  ...) {
  stopifnot(baseSize > 0)
  if ( length(breaks) == 1 ) {
    breaks <- pretty(values, breaks, ...)
  }
  sizes <- sizeNumeric(values = breaks, baseSize = baseSize, minSize = minSize,
    maxSize = maxSize, centerPoint = mean(values, na.rm = TRUE))
  stats::setNames(sizes, breaks)[breaks > 0 & breaks <= max(values)]
}

#' @export
#'
#' @rdname mapSymbols
makeSymbolsSize <- function(values,
                          shape = 'rect',
                          color,
                          fillColor,
                          opacity = 1,
                          fillOpacity = opacity,
                          strokeWidth = 1,
                          baseSize,
                          minSize = NULL,
                          maxSize = NULL,
                          ...
                          ) {
  stopifnot(strokeWidth >= 0)
  stopifnot(length(color) == 1 || length(color) == length(values))
  stopifnot(length(fillColor) == 1 || length(fillColor) == length(values))
  stopifnot(length(shape) < 2)
  sizes <- sizeNumeric(values, baseSize, minSize = minSize, maxSize = maxSize)
  makeSymbolIcons(
    shape = shape,
    width = sizes,
    height = sizes,
    color = color,
    fillColor = fillColor,
    opacity = opacity,
    fillOpacity = fillOpacity,
    strokeWidth = strokeWidth,
    ...
  )
}
#' @param width
#'
#' width in pixels of the lines
#'
#' @export
#'
#' @rdname legendSymbols
addLegendLine <- function(map,
                          pal,
                          values,
                          title = NULL,
                          labelStyle = 'vertical-align: middle;',
                          orientation = c('vertical', 'horizontal'),
                          width = 20,
                          color,
                          opacity = 1,
                          fillOpacity = opacity,
                          breaks = 5,
                          baseSize = 10,
                          minSize = NULL,
                          maxSize = NULL,
                          numberFormat = function(x) {
                            prettyNum(x, big.mark = ',', scientific = FALSE,
                                      digits = 1)
                            },
                          group = NULL,
                          className = 'info legend leaflet-control',
                          data = leaflet::getMapData(map),
                          ...) {
  shape <- 'rect'
  values <- parseValues(values = values, data = data)
  sizes <- sizeBreaks(values, breaks, baseSize, minSize = minSize, 
    maxSize = maxSize)
  if ( missing(color) ) {
    stopifnot( missing(color) & !missing(pal))
    colors <- pal(as.numeric(names(sizes)))
  } else {
    stopifnot(length(color) == 1 || length(color) == length(breaks))
    colors <- color
  }
  labels <- numberFormat(as.numeric(names(sizes)))
  if (length(names(breaks)) == length(breaks) && length(breaks) > 1) {
    labels <- names(breaks)
  }
  symbols <- Map(makeSymbol,
                 shape = shape,
                 width = width,
                 height = sizes,
                 color = 'transparent',
                 fillColor = colors,
                 opacity = opacity,
                 fillOpacity = fillOpacity,
                 `stroke-width` = 0)
  addLegendImage(map, images = symbols,
                 labels = labels,
                 title = title, labelStyle = labelStyle,
                 orientation = orientation, width = width, height = sizes,
                 group = group, className = className, ...)

}

#' @param height
#'
#' in pixels
#'
#' @param dashArray
#'
#' a string or vector/list of strings that defines the stroke dash pattern
#'
#' @param label
#'
#' a character vector of labels to display at the center of each symbol
#'
#' @export
#'
#' @rdname legendSymbols
addLegendSymbol <- function(map,
                            pal,
                            values,
                            title = NULL,
                            labelStyle = 'vertical-align: middle;',
                            shape,
                            orientation = c('vertical', 'horizontal'),
                            color,
                            fillColor = color,
                            strokeWidth = 1,
                            opacity = 1,
                            fillOpacity = opacity,
                            width = 20,
                            height = width,
                            group = NULL,
                            className = 'info legend leaflet-control',
                            dashArray = NULL,
                            label = NULL,
                            data = leaflet::getMapData(map),
                            ...
) {
  if (missing(shape)) {
    shape <- availableShapes()[['default']]
  }
  values <- sort(unique(as.factor(parseValues(values, data))))
  if ( length(levels(values)) > length(shape) ) {
    stop('values has more factor levels than shape. Maximum levels is 7')
  }
  shape <- shape[values]
  if ( missing(color) ) {
    stopifnot( missing(color) & !missing(pal))
    colors <- pal(values)
  } else {
    stopifnot(length(color) == 1 || length(color) == length(values))
    colors <- color
  }
  if ( missing(fillColor) ) {
    if ( !missing(pal) ) {
      fillColors <- pal(values)
    } else {
      fillColors <- colors
    }
  } else {
    stopifnot(length(fillColor) == 1 || length(fillColor) == length(values))
    fillColors <- fillColor
  }
  if (is.null(dashArray)) {
    dashArray <- 'none'
  }
  label <- parseValues(label, data)
  args <- list(makeSymbol,
               shape = shape,
               width = width,
               height = height,
               color = colors,
               fillColor = fillColors,
               opacity = opacity,
               fillOpacity = fillOpacity,
               `stroke-width` = strokeWidth,
               `stroke-dasharray` = dashArray)
  if (!is.null(label)) {
    args <- append(args, list(label = label))
  }
  symbols <- do.call(Map, args)
  addLegendImage(map, images = symbols,
                 labels = as.character(values),
                 title = title, labelStyle = labelStyle,
                 orientation = orientation, width = width, height = height,
                 group = group, className = className, ...)
}

#' @param text
#'
#' character vector of labels to render inside each symbol. For
#' addLegendText, length must match the number of unique values; if omitted
#' the levels themselves are used. For addLegendTextSize, required and must be
#' a single string, which is rendered at each break size.
#'
#' @param labels
#'
#' optional character vector of labels to display beside each text symbol in
#' addLegendText; length must match the number of unique values. If
#' \code{NULL} (the default) no labels are added and only the symbols are shown.
#'
#' @param fontSize
#'
#' size of the text in pixels for addLegendText; defaults to
#' \code{round(min(width, height) * 0.6)}
#'
#' @param fontFamily
#'
#' optional font family for the svg text; if \code{NULL} the browser default
#' is used
#'
#' @export
#'
#' @rdname legendSymbols
addLegendText <- function(map,
                          pal,
                          values,
                          text,
                          labels = NULL,
                          title = NULL,
                          labelStyle = 'vertical-align: middle;',
                          orientation = c('vertical', 'horizontal'),
                          color,
                          fillColor = color,
                          opacity = 1,
                          fillOpacity = opacity,
                          width = 20,
                          height = width,
                          fontSize = round(min(width, height) * 0.6),
                          fontFamily = NULL,
                          group = NULL,
                          className = 'info legend leaflet-control',
                          data = leaflet::getMapData(map),
                          ...) {
  values <- sort(unique(as.factor(parseValues(values, data))))
  if (missing(text)) {
    text <- as.character(values)
  } else {
    stopifnot(length(text) == length(values))
  }
  if (is.null(labels)) {
    labels <- rep('', length(values))
  } else {
    stopifnot(length(labels) == length(values))
  }
  if ( missing(color) ) {
    stopifnot( missing(color) & !missing(pal))
    colors <- pal(values)
  } else {
    stopifnot(length(color) == 1 || length(color) == length(values))
    colors <- color
  }
  if ( missing(fillColor) ) {
    if ( !missing(pal) ) {
      fillColors <- pal(values)
    } else {
      fillColors <- colors
    }
  } else {
    stopifnot(length(fillColor) == 1 || length(fillColor) == length(values))
    fillColors <- fillColor
  }
  mapArgs <- list(
    f = makeSymbolText,
    text = text,
    width = width,
    height = height,
    color = colors,
    fillColor = fillColors,
    opacity = opacity,
    fillOpacity = fillOpacity,
    fontSize = fontSize
  )
  if (!is.null(fontFamily)) {
    mapArgs[['fontFamily']] <- fontFamily
  }
  symbols <- do.call(Map, mapArgs)
  addLegendImage(map, images = symbols,
                 labels = labels,
                 title = title, labelStyle = labelStyle,
                 orientation = orientation, width = width, height = height,
                 group = group, className = className, ...)
}

#' @export
#'
#' @rdname legendSymbols
addLegendTextSize <- function(map,
                              pal,
                              values,
                              text,
                              title = NULL,
                              labelStyle = 'vertical-align: middle;',
                              orientation = c('vertical', 'horizontal'),
                              color,
                              fillColor = color,
                              opacity = 1,
                              fillOpacity = opacity,
                              breaks = 5,
                              baseSize = 20,
                              numberFormat = function(x) {
                                prettyNum(x, big.mark = ',', scientific = FALSE,
                                          digits = 1)
                                },
                              fontFamily = NULL,
                              group = NULL,
                              className = 'info legend leaflet-control',
                              data = leaflet::getMapData(map),
                              ...) {
  stopifnot(!missing(text), length(text) == 1)
  values <- parseValues(values = values, data = data)
  sizes <- sizeBreaks(values, breaks, baseSize)
  if ( missing(color) ) {
    stopifnot( missing(color) & !missing(pal))
    colors <- pal(as.numeric(names(sizes)))
  } else {
    stopifnot(length(color) == 1 || length(color) == length(breaks))
    colors <- color
  }
  if ( missing(fillColor) ) {
    if ( !missing(pal) ) {
      fillColors <- pal(as.numeric(names(sizes)))
    } else {
      fillColors <- colors
    }
  } else {
    stopifnot(length(fillColor) == 1 || length(fillColor) == length(breaks))
    fillColors <- fillColor
  }
  labels <- numberFormat(as.numeric(names(sizes)))
  if (length(names(breaks)) == length(breaks) && length(breaks) > 1) {
    labels <- names(breaks)
  }
  widths <- sizes * 0.6 * nchar(text)
  mapArgs <- list(
    f = makeSymbolText,
    text = text,
    width = widths,
    height = sizes,
    color = colors,
    fillColor = fillColors,
    opacity = opacity,
    fillOpacity = fillOpacity,
    fontSize = round(sizes * 0.6)
  )
  if (!is.null(fontFamily)) {
    mapArgs[['fontFamily']] <- fontFamily
  }
  symbols <- do.call(Map, mapArgs)
  addLegendImage(map, images = symbols,
                 labels = labels,
                 title = title, labelStyle = labelStyle,
                 orientation = orientation,
                 width = widths,
                 height = sizes,
                 group = group, className = className, ...)
}

#' Add a legend with Awesome Icons
#'
#' @param map
#'
#' a map widget object created from 'leaflet'
#'
#' @param iconSet
#'
#' a named list from \link[leaflet]{awesomeIconList}, the names will be the
#' labels in the legend
#'
#' @param title
#'
#' the legend title, pass in HTML to style
#'
#' @param labelStyle
#'
#' character string of style argument for HTML text
#'
#' @param marker
#'
#' whether to show the marker or only the icon
#'
#' @param orientation
#'
#' stack the legend items vertically or horizontally
#'
#' @param group
#'
#' group name of a leaflet layer group
#'
#' @param className
#'
#' extra CSS class to append to the control, space separated
#'
#' @param ...
#'
#' arguments to pass to \link[leaflet]{addControl}
#'
#' @return
#'
#' an object from \link[leaflet]{addControl}
#'
#' @export
#'
#' @examples
#' library(leaflet)
#' data(quakes)
#' iconSet <- awesomeIconList(
#'   `Font Awesome` = makeAwesomeIcon(icon = "font-awesome", library = "fa",
#'                                    iconColor = 'gold', markerColor = 'red',
#'                                    spin = FALSE,
#'                                    squareMarker = TRUE,
#'                                    iconRotate = 30,
#'   ),
#'   Ionic = makeAwesomeIcon(icon = "ionic", library = "ion",
#'                           iconColor = '#ffffff', markerColor = 'blue',
#'                           spin = TRUE,
#'                           squareMarker = FALSE),
#'   Glyphicon = makeAwesomeIcon(icon = "plus-sign", library = "glyphicon",
#'                               iconColor = 'rgb(192, 255, 0)',
#'                               markerColor = 'darkpurple',
#'                               spin = TRUE,
#'                               squareMarker = FALSE)
#' )
#' leaflet(quakes[1:3,]) %>%
#'   addTiles() %>%
#'   addAwesomeMarkers(lat = ~lat,
#'                     lng = ~long,
#'                     icon = iconSet) %>%
#'   addLegendAwesomeIcon(iconSet = iconSet,
#'                        orientation = 'horizontal',
#'                        title = htmltools::tags$div(
#'                          style = 'font-size: 20px;',
#'                          'Awesome Icons'),
#'                        labelStyle = 'font-size: 16px;') %>%
#'   addLegendAwesomeIcon(iconSet = iconSet,
#'                        orientation = 'vertical',
#'                        marker = FALSE,
#'                        title = htmltools::tags$div(
#'                          style = 'font-size: 20px;',
#'                          'Awesome Icons'),
#'                        labelStyle = 'font-size: 16px;')
addLegendAwesomeIcon <- function(map,
                                 iconSet,
                                 title = NULL,
                                 labelStyle = 'vertical-align: middle;',
                                 orientation = c('vertical', 'horizontal'),
                                 marker = TRUE,
                                 group = NULL,
                                 className = 'info legend leaflet-control',
                                 ...) {
  stopifnot(inherits(iconSet, 'leaflet_awesome_icon_set'))
  stopifnot( !is.null(names(iconSet)) &&
               length(names(iconSet)) == length(iconSet) )
  orientation <- match.arg(orientation)
  if ( orientation == 'vertical' ) {
    wrapElements <- htmltools::tags$div
  } else {
    wrapElements <- htmltools::tags$span
  }
  currentDepNames <- vapply(map$dependencies, getElement, name = 'name',
                            FUN.VALUE = 'character')
  iconLibraries <- unique(vapply(iconSet, getElement, name = 'library',
                                 FUN.VALUE = character(1)))
  verifyIconLibrary(iconLibraries)
  iconLibraries <- c(
    fa = 'fontawesome',
    ion = 'ionicons',
    glyphicon = 'bootstrap')[iconLibraries]
  missingDeps <- setdiff(c('leaflet-awesomemarkers', iconLibraries),
                         currentDepNames)
  iconDeps <- c(
    `leaflet-awesomemarkers` = leafletAwesomeMarkersDependencies(),
    fontawesome = leafletAmFontAwesomeDependencies(),
    ion = leafletAmIonIconDependencies(),
    bootstrap = leafletAmBootstrapDependencies())[missingDeps]
  map$dependencies <- c(map$dependencies, unname(iconDeps))
  htmlElements <-
    Map(icon = iconSet,
        label = names(iconSet),
        f = function(icon, label) {
          markerClass <- ''
          if ( marker ) {
            markerClass <- sprintf(
              'awesome-marker-icon-%s awesome-marker %s',
              icon[['markerColor']],
              ifelse(icon[['squareMarker']], 'awesome-marker-square', ''))
          }
      htmltools::tagList(
        wrapElements(
        htmltools::tags$div(
          style = 'vertical-align: middle; display:
          inline-block; position: relative;',
              class = markerClass,
              htmltools::tags$i(class = sprintf('%1$s %1$s-%2$s %3$s',
                                                icon[['library']],
                                                icon[['icon']],
                                                ifelse(icon[['spin']], 'fa-spin', '')),
                                style = sprintf('color: %s; %s; margin-right: 0px', icon[['iconColor']],
                                                ifelse(icon[['iconRotate']] == 0, '',
                                                       sprintf('-webkit-transform: rotate(%1$sdeg);-moz-transform: rotate(%1$sdeg);-o-transform: rotate(%1$sdeg);-ms-transform: rotate(%1$sdeg);transform: rotate(%1$sdeg);',
                                                               icon[['iconRotate']]))
                                ),
                                if ( !is.null(icon[['text']]) ) {
                                  icon[['text']]
                                  }
              )
        ),
        htmltools::tags$span(label, style = sprintf('%s', labelStyle))
      )
      )
    })
  htmlElements <- addTitle(title = title, htmlElements = htmlElements)
  leaflegendAddControl(map, html = htmltools::tagList(htmlElements),
                       className = className, group = group, ...)
}

leaflegendAddControl <- function(map,
                                 html,
                                 className,
                                 group,
                                 ...) {

  if ( !is.null(group) ) {
    groupText <- gsub('<[^>]*>', '', group)
    leafLegendClassName <- paste('leaflegend-group',
                                 gsub('[^a-zA-Z0-9]', '', groupText),
                                 sep = '-')
    className <- paste(className, leafLegendClassName)

    lf <- leaflet::addControl(map, html = html, className = className, ...)
    htmlwidgets::onRender(lf, "
function(el, x) {
  var updateLeafLegend = function() {
    var controlGroups = el.querySelectorAll(
      'input.leaflet-control-layers-selector');
    controlGroups.forEach(g => {
      var groupName = g.nextSibling.textContent.substr(1);
      var className = 'leaflegend-group-' +
        groupName.replace(/[^a-zA-Z0-9]/g, '');
      var checked = g.checked;
      el.querySelectorAll('.legend.' + className).forEach(l => {
        l.hidden = !checked;
      })
    })
  }
  // wait for the current batch of map updates to finish; rendering is
  // deferred while the map is hidden and the layers control does not exist
  // until it completes
  var updateTimer = null;
  var scheduleUpdate = function() {
    clearTimeout(updateTimer);
    updateTimer = setTimeout(updateLeafLegend, 0);
  }

  updateLeafLegend();
  this.on('layeradd', scheduleUpdate);
  this.on('layerremove', scheduleUpdate);
  this.on('baselayerchange', scheduleUpdate);
  this.on('overlayadd', scheduleUpdate);
  this.on('overlayremove', scheduleUpdate);
}
                        ")
  } else {
    leaflet::addControl(map, html = html, className = className, ...)
  }
}

parseValues <- function(values, data) {
  if ( inherits(values, 'formula') ) {
    stopifnot(!is.null(data))
    leaflet::evalFormula(values, data)
  } else {
    values
  }
}

#' Available shapes for map symbols
#'
#' @return
#'
#' list of available shapes
#'
#' @export
#'
availableShapes <- function() {
  list(
    'default' =
      c('rect', 'circle', 'triangle', 'plus', 'cross', 'diamond', 'star',
        'stadium', 'line', 'polygon'),
    'pch' =
      c('open-rect', 'open-circle', 'open-triangle', 'simple-plus',
        'simple-cross', 'open-diamond', 'open-down-triangle', 'cross-rect',
        'simple-star', 'plus-diamond', 'plus-circle', 'hexagram', 'plus-rect',
        'cross-circle', 'triangle-rect', 'solid-rect', 'solid-circle-md',
        'solid-triangle', 'solid-diamond', 'solid-circle-bg', 'solid-circle-sm',
        'circle', 'rect', 'diamond', 'triangle', 'down-triangle'
      ),
    'special' = c('text')
  )
}

# Borrowed from "leaflet" package internal functions
leafletAmBootstrapDependencies <- function() {
  list(htmltools::htmlDependency(
    "bootstrap", "3.3.7", "htmlwidgets/plugins/Leaflet.awesome-markers",
    package = "leaflet", script = c("bootstrap.min.js"),
    stylesheet = c("bootstrap.min.css")))
}
leafletAmFontAwesomeDependencies <- function() {
  list(htmltools::htmlDependency(
    "fontawesome", "4.7.0", "htmlwidgets/plugins/Leaflet.awesome-markers",
    package = "leaflet", stylesheet = c("font-awesome.min.css")))
}
leafletAmIonIconDependencies <- function() {
  list(htmltools::htmlDependency(
    "ionicons", "2.0.1", "htmlwidgets/plugins/Leaflet.awesome-markers",
    package = "leaflet", stylesheet = c("ionicons.min.css")))
}
leafletAwesomeMarkersDependencies <- function() {
  list(htmltools::htmlDependency(
    "leaflet-awesomemarkers",
    "2.0.3", "htmlwidgets/plugins/Leaflet.awesome-markers",
    package = "leaflet", script = c("leaflet.awesome-markers.min.js"),
    stylesheet = c("leaflet.awesome-markers.css")))

}
verifyIconLibrary <- function(library) {
  bad <- library[!(library %in% c("glyphicon", "fa", "ion"))]
  if (length(bad) > 0) {
    stop("Invalid icon library names: ", paste(unique(bad), collapse = ", "))
  }
}