R/legend.R

In googleway: Accesses Google Maps APIs to Retrieve Data and Plot Maps

resolveLegend <- function(legend, legend_options, colour_palettes){

  if( length( colour_palettes ) == 0 & any(vapply(legend, isTRUE, T) ) ) {
    warning("nothing to include in the legend")
    legend <- FALSE
  }


  if(any(vapply(legend, isTRUE, T))){
    legend <- constructLegend(colour_palettes, legend)
    if(!is.null(legend_options)){
      legend <- addLegendOptions(legend, legend_options)
    }
  }
  return(legend)
}


constructLegend <- function(colour_palettes, legend){

  ## remove any colour_palettes not needed
  cp <- sapply(colour_palettes, function(x) names(x[['variables']]))

  legend <- flattenLegend(legend)

  cp <- cp[cp %in% legend]

  ## cp are now the valid colours
  lst <- lapply(colour_palettes, function(x){

    if(all(names(x[['variables']]) %in% cp)){

      ## format the palette - needs binning if it's gradient
      type <- getLegendType(x$palette[['variable']])
      x$palette <- formatPalette(x$palette, type)

      list(
        ## if both a fill and stroke are used, fill takes precedence
        colourType = ifelse('fill_colour' %in% names(x$variables), 'fill_colour', 'stroke_colour'),
        type = type,
        title = unique(x$variable),
        legend = x$palette,
        css = NULL,
        position = NULL
      )
    }
  })

  lst[sapply(lst, is.null)] <- NULL
  return(lst)
}

# Format Palette
#
# Formats the palette ready for the legend. A gradient palette is reduced
# to a selected number of 'bins'. A category legend is returned as-is
#
# @param palette the colour palette to format (returned from createColourPalettes())
# @param type the type of leged/palette (returned from getLegendType)
formatPalette <- function(palette, type){
  ## palette shoudl be a data.frame
  if(type == "gradient"){

    ## TODO:
    ## - better representation of the min & max values on the legend
    ## - options:
    ## -- show the min & max at the extremeties of the legend
    ## -- have an option to 'turn off maximum/minimum values
    ## -- which will then remove the maxima, and instead use < and + as a
    ## -- prefix and suffix to the min/max values

    # rows <- 1:32434



    palette <- palette[with(palette, order(variable)), ]

    ## cut the palette
    rows <- 1:nrow(palette)
    rowRange <- range(rows)
    rw <- unique(round(pretty(rows, n = 5)))
    rw <- rw[rw >= rowRange[1] & rw <= rowRange[2]]

    if(rw[1] != 1) rw <- c(1, rw)
    if(rw[length(rw)] != nrow(palette)) rw <- c(rw, nrow(palette))

    palette <- palette[rw, ]
  }
  return(palette)
}

# Get Legned Type
# determins the type of legend to plot given the data
# @param colourColum
getLegendType <- function(colourColumn) UseMethod("getLegendType")

#' @export
getLegendType.numeric <- function(colourColumn) "gradient"

#' @export
getLegendType.default <- function(colourColumn) "category"



flattenLegend <- function(legend) UseMethod("flattenLegend")

#' @export
flattenLegend.list <- function(legend){
  legend <- unlist(legend)
  legend <- names(legend)[legend == T]
  return(legend)
}

#' @export
flattenLegend.logical <- function(legend){
  if(length(names(legend)) > 0){
    ## it's a named vector
    legend <- names(legend)[legend]
  }else{
    legend <- c("fill_colour", "stroke_colour")[legend]
  }
  return(legend)
}

# add legend options
#
# updates a legend with various options
#
# @param legend constructed from constructLegend()
# @param legend_options list of user defined legend options
addLegendOptions <- function(legend, legend_options){

  ## If any names of legend_options not in c("fill_colour", "stroke_colour")
  ## then those will be applied to all
  ## otherwise, it will be either a fill_colour or a stroke_colour
  nonAesthetics <- names(legend_options)[!names(legend_options) %in% c("fill_colour", "stroke_colour")]

  if(length(nonAesthetics) > 0){
    ## then we can't use the individual mappings
    legend <- lapply(legend, replaceLegendOption, legend_options)
  }else{
    ## apply the mappings directly to the aesthetics
    toMapDirectly <- names(legend_options)[names(legend_options) %in% c("fill_colour", "stroke_colour")]
    toMapDirectly <- toMapDirectly[vapply(toMapDirectly, function(x) is.list(legend_options[[x]]), T)]

    legend <- lapply(c("fill_colour", "stroke_colour"), function(x){
      idx <- which(vapply(legend, function(y) y$colourType == x, T))
      if(length(idx) > 0){
        replaceLegendOption(legend[[idx]], legend_options[[x]])
      }
    })
  }

  return(legend)
}

replaceLegendOption <- function(legend, legend_option){

  if(!is.null(legend_option[['title']]))
    legend[['title']] <- legend_option[['title']]

  if(!is.null(legend_option[['css']]))
    legend[['css']] <- legend_option[['css']]

  if(!is.null(legend_option[['position']]))
    legend[['position']] <- legend_option[['position']]


  ## reverse
  if(isTRUE(legend_option[['reverse']])){
    df <- legend[['legend']]
    legend[['legend']] <- df[dim(df)[1]:1,]
  }


  #### Formatting values
  legend[['legend']][, 'variable'] <- formatLegendValue(legend[['legend']][, 'variable'])

  if(!is.null(legend_option[['prefix']]))
    legend[['legend']][, 'variable'] <- paste0(legend_option[['prefix']], legend[['legend']][, 'variable'])

  if(!is.null(legend_option[['suffix']]))
    legend[['legend']][, 'variable'] <- paste0(legend[['legend']][, 'variable'], legend_option[['suffix']])

  return(legend)
}


formatLegendValue <- function(legendValue) UseMethod("formatLegendValue")

#' @export
formatLegendValue.numeric <- function(legendValue) format(legendValue, big.mark = ",")

#' @export
formatLegendValue.POSIXct <- function(legendValue){
  tz <- attr(legendValue, 'tzone')
  as.Date(legendValue, tz = tz)
}

#' @export
formatLegendValue.default <- function(legendValue) legendValue