R/google_map_layer_circle.R

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

googleCircleDependency <- function() {
  list(
    createHtmlDependency(
      name = "circles",
      version = "1.0.0",
      src = system.file("htmlwidgets/lib/circles", package = "googleway"),
      script = c("circles.js"),
      all_files = FALSE
    )
  )
}


#' Add circle
#'
#' Add circles to a google map
#'
#' @param map a googleway map object created from \code{google_map()}
#' @param data data frame containing the data to use in the layer. If Null, the
#' data passed into \code{google_map()} will be used.
#' @param id string specifying the column containing an identifier for a shape
#' @param lat string specifying the column of \code{data} containing the 'latitude'
#' coordinates. If left NULL, a best-guess will be made
#' @param lon string specifying the column of \code{data} containing the 'longitude'
#' coordinates. If left NULL, a best-guess will be made
#' @param polyline string specifying the column of \code{data} containing the encoded polyline.
#' For circles and markers the encoded string will represent a single point.
#' @param radius either a string specifying the column of \code{data} containing the
#' radius of each circle, OR a numeric value specifying the radius of all the circles
#' (radius is expressed in metres)
#' @param draggable string specifying the column of \code{data} defining if
#' the polygon is 'draggable'. The column of data should be logical (either TRUE or FALSE)
#' @param editable string specifying the column of \code{data} defining if the polygon
#' is 'editable' (either TRUE or FALSE)
#' @param stroke_colour either a string specifying the column of \code{data} containing
#' the stroke colour of each shape, or a valid hexadecimal numeric HTML style to
#' be applied to all the shapes
#' @param stroke_opacity either a string specifying the column of \code{data} containing
#' the stroke opacity of each shape, or a value between 0 and 1 that will be
#' applied to all the shapes
#' @param stroke_weight either a string specifying the column of \code{data} containing
#' the stroke weight of each shape, or a number indicating the width of pixels
#' in the line to be applied to all the shapes
#' @param fill_colour either a string specifying the column of \code{data} containing
#' the fill colour of each shape, or a valid hexadecimal numeric HTML style to
#' be applied to all the shapes
#' @param fill_opacity either a string specifying the column of \code{data} containing
#' the fill opacity of each shape, or a value between 0 and 1 that will be applied
#' to all the shapes
#' @param info_window string specifying the column of data to display in an info
#' window when a shape is clicked.
#' @param mouse_over string specifying the column of data to display when the
#' mouse rolls over the shape
#' @param mouse_over_group string specifying the column of data specifying which
#' groups of shapes to highlight on mouseover
#' @param layer_id single value specifying an id for the layer. Use this value to
#' distinguish between shape layers for when using any \code{update_} function, and
#' for separating legends.
#' @param update_map_view logical specifying if the map should re-centre according to
#' the shapes
#' @param z_index single value specifying where the circles appear in the layering
#' of the map objects. Layers with a higher \code{z_index} appear on top of those with
#' a lower \code{z_index}. See details.
#' @param digits integer. Use this parameter to specify how many digits (decimal places)
#' should be used for the latitude / longitude coordinates.
#' @param palette a function, or list of functions, that generates hex colours
#' given a single number as an input. See details.
#' @param legend either a logical indiciating if the legend(s) should be displayed, or
#' a named list indicating which colour attributes should be included in the legend.
#' @param legend_options A list of options for controlling the legend.
#' @param load_interval time in miliseconds to wait between plotting each shape
#' @param focus_layer logical indicating if the map should re-centre according to this layer
#'
#' @section palette:
#'
#' The \code{palette} is used to specify the colours that will map to variables.
#' You can specify a single function to map to all variables, or a named list
#' that specifies a separate function to map to each variable. The elements must
#' be named either \code{fill_colour} or \code{stroke_colour}, and their values
#' are the colour generating functions. The default is \code{viridisLite::viridis}
#'
#' The \code{legend_options} can be used to control the appearance of the legend.
#' This should be a named list, where the names are one of
#' \itemize{
#'   \item{position - one of \code{c("TOP_LEFT", "TOP_CENTER", "TOP_RIGHT", "RIGHT_TOP",
#'   "RIGHT_CENTER", "RIGHT_BOTTOM", "BOTTOM_RIGHT", "BOTTOM_CENTER", "BOTTOM_LEFT",
#'   "LEFT_BOTTOM", "LEFT_CENTER", "LEFT_TOP")}}
#'   \item{css - a string of valid \code{css} for controlling the appearance of the legend}
#'   \item{title - a string to use for the title of the legend}
#'}
#' if \code{legend_options} are NULL, the default values will apply
#'
#' If you are displaying two legends, one for \code{stroke_colour} and one
#' for \code{fill_colour}, you can specify different options for the different
#' colour attributes. See examples for \link{add_circles}.
#'
#' @details
#'
#' \code{z_index} values define the order in which objects appear on the map.
#' Those with a higher value appear on top of those with a lower value. The default
#' order of objects is (1 being underneath all other objects)
#'
#' \itemize{
#'   \item{1. Polygon}
#'   \item{2. Rectangle}
#'   \item{3. Polyline}
#'   \item{4. Circle}
#' }
#'
#' Markers are always the top layer
#'
#' @examples
#' \dontrun{
#'
#' map_key <- 'your_api_key'
#'
#' google_map(key = map_key, data = tram_stops) %>%
#'  add_circles(lat = "stop_lat", lon = "stop_lon", fill_colour = "stop_name",
#'  stroke_weight = 0.3, stroke_colour = "stop_name", info_window ="stop_id")
#'
#' ## different colour palettes
#' lstPalette <- list(fill_colour = colorRampPalette(c("red","blue")),
#'     stroke_colour = viridisLite::plasma)
#'
#' ## set the key via set_key()
#' set_key(key = map_key)
#'
#' google_map(data = tram_stops) %>%
#'  add_circles(lat = "stop_lat", lon = "stop_lon", fill_colour = "stop_lat",
#'  stroke_weight = 2, stroke_colour = "stop_name", palette = lstPalette, legend = T)
#'
#' ## controlling the legend
#' google_map(data = tram_stops) %>%
#'  add_circles(lat = "stop_lat", lon = "stop_lon", fill_colour = "stop_lat",
#'  stroke_weight = 2, stroke_colour = "stop_name",
#'  legend = c(fill_colour = T, stroke_colour = F),
#'  legend_options = list(position = "TOP_RIGHT", css = "max-height: 100px;"))
#'
#'google_map(data = tram_stops) %>%
#'  add_circles(lat = "stop_lat", lon = "stop_lon", fill_colour = "stop_lat",
#'  stroke_weight = 2, stroke_colour = "stop_name",
#'  legend = T,
#'  legend_options = list(
#'    fill_colour = list(position = "TOP_RIGHT", css = "max-height: 100px;"),
#'    stroke_colour = list(position = "LEFT_BOTTOM", title = "Stop Name")
#'    ))
#'
#'
#'  }
#' @export
add_circles <- function(map,
                        data = get_map_data(map),
                        id = NULL,
                        lat = NULL,
                        lon = NULL,
                        polyline = NULL,
                        radius = NULL,
                        editable = NULL,
                        draggable = NULL,
                        stroke_colour = NULL,
                        stroke_opacity = NULL,
                        stroke_weight = NULL,
                        fill_colour = NULL,
                        fill_opacity = NULL,
                        mouse_over = NULL,
                        mouse_over_group = NULL,
                        info_window = NULL,
                        layer_id = NULL,
                        update_map_view = TRUE,
                        z_index = NULL,
                        digits = 4,
                        palette = NULL,
                        legend = F,
                        legend_options = NULL,
                        load_interval = 0,
                        focus_layer = FALSE
                        ){

  #objArgs <- match.call(expand.dots = F)
  objArgs <- list()
  objArgs[["id"]] <- force( id )
  objArgs[["lat"]] <- force( lat )
  objArgs[["lon"]] <- force( lon )
  objArgs[["polyline"]] <- force( polyline )
  objArgs[["radius"]] <- force( radius )
  objArgs[["editable"]] <- force( editable )
  objArgs[["draggable"]] <- force( draggable )
  objArgs[["stroke_colour"]] <- force( stroke_colour )
  objArgs[["stroke_opacity"]] <- force( stroke_opacity )
  objArgs[["stroke_weight"]] <- force( stroke_weight )
  objArgs[["fill_colour"]] <- force( fill_colour )
  objArgs[["fill_opacity"]] <- force( fill_opacity )
  objArgs[["mouse_over"]] <- force( mouse_over )
  objArgs[["mouse_over_group"]] <- force( mouse_over_group )
  objArgs[["info_window"]] <- force( info_window )
  objArgs[["layer_id"]] <- force( layer_id )
  objArgs[["update_map_view"]] <- force( update_map_view )
  objArgs[["z_index"]] <- force( z_index )
  objArgs[["digits"]] <- force( digits )
  objArgs[["palette"]] <- force( palette )
  objArgs[["legend"]] <- force( legend )
  objArgs[["legend_options"]] <- force( legend_options )
  objArgs[["load_interval"]] <- force( load_interval )
  objArgs[["focus_layer"]] <- force( focus_layer )


  data <- normaliseSfData(data, "POINT")
  polyline <- findEncodedColumn(data, polyline)

  if( !is.null(polyline) && !polyline %in% names(objArgs) ) {
    objArgs[['polyline']] <- polyline
  }

  ## PARAMETER CHECKS
  if(!dataCheck(data, "add_circles")) data <- circleDefaults(1)
  layer_id <- layerId(layer_id)

  usePolyline <- isUsingPolyline(polyline)

  if( !usePolyline ) {
    objArgs <- latLonCheck(objArgs, lat, lon, names(data), "add_circles")
  }

  infoWindowChart <- NULL
  if (!is.null(info_window) && isInfoWindowChart(info_window)) {
    infoWindowChart <- info_window
    objArgs[['info_window']] <- NULL
  }

  logicalCheck(update_map_view)
  logicalCheck(focus_layer)
  numericCheck(digits)
  numericCheck(z_index)
  loadIntervalCheck(load_interval)
  palette <- paletteCheck(palette)

  objArgs <- zIndexCheck( objArgs, z_index )

  ## END PARAMETER CHECKS

  allCols <- circleColumns()
  requiredCols <- requiredCircleColumns()
  colourColumns <- shapeAttributes(fill_colour = fill_colour, stroke_colour = stroke_colour)

  shape <- createMapObject(data, allCols, objArgs)
  pal <- createPalettes(shape, colourColumns)
  colour_palettes <- createColourPalettes(data, pal, colourColumns, palette)
  colours <- createColours(shape, colour_palettes)

  if(length(colours) > 0){
    shape <- replaceVariableColours(shape, colours)
  }

  ## LEGEND
  legend <- resolveLegend(legend, legend_options, colour_palettes)

  requiredDefaults <- setdiff(requiredCols, names(shape))
  if(length(requiredDefaults) > 0){
    shape <- addDefaults(shape, requiredDefaults, "circle")
  }

  if( usePolyline ) {
    shape <- createPolylineListColumn(shape)
  }

  shape <- createInfoWindowChart(shape, infoWindowChart, id)
  shape <- jsonlite::toJSON(shape, digits = digits)

  map <- addDependency(map, googleCircleDependency())

  invoke_method(map, 'add_circles', shape, update_map_view, layer_id, usePolyline, legend, load_interval, focus_layer)
}

#' @rdname clear
#' @export
clear_circles <- function(map, layer_id = NULL){
  layer_id <- layerId(layer_id)
  invoke_method(map, 'clear_circles', layer_id)
}


#' Update circles
#'
#' Updates specific colours and opacities of specified circles Designed to be
#' used in a shiny application.
#'
#' @note Any circles (as specified by the \code{id} argument) that do not exist
#' in the \code{data} passed into \code{add_circles()} will not be added to the map.
#' This function will only update the circles that currently exist on the map when
#' the function is called.
#'
#' @inheritParams add_circles
#' @param id string representing the column of \code{data} containing the id values
#' for the shapes. The id values must be present in the original data supplied to in order
#' for the shape to be udpated.
#'
#' @export
update_circles <- function(map, data, id,
                           radius = NULL,
                           draggable = NULL,
                           stroke_colour = NULL,
                           stroke_weight = NULL,
                           stroke_opacity = NULL,
                           fill_colour = NULL,
                           fill_opacity = NULL,
                           info_window = NULL,
                           layer_id = NULL,
                           digits = 4,
                           palette = NULL,
                           legend = F,
                           legend_options = NULL
                           ){

  # objArgs <- match.call(expand.dots = F)

  objArgs <- list()
  objArgs[["id"]] <- force( id )
  objArgs[["radius"]] <- force( radius )
  objArgs[["draggable"]] <- force( draggable )
  objArgs[["stroke_colour"]] <- force( stroke_colour )
  objArgs[["stroke_weight"]] <- force( stroke_weight )
  objArgs[["stroke_opacity"]] <- force( stroke_opacity )
  objArgs[["fill_colour"]] <- force( fill_colour )
  objArgs[["fill_opacity"]] <- force( fill_opacity )
  objArgs[["info_window"]] <- force( info_window )
  objArgs[["layer_id"]] <- force( layer_id )
  objArgs[["digits"]] <- force( digits )
  objArgs[["palette"]] <- force( palette )
  objArgs[["legend"]] <- force( legend )
  objArgs[["legend_options"]] <- force( legend_options )

  # data <- normaliseSfData(data, "POINT")
  # polyline <- findEncodedColumn(data, polyline)
  #
  # if( !is.null(polyline) && !polyline %in% names(objArgs) ) {
  #   objArgs[['polyline']] <- polyline
  # }

  layer_id <- layerId(layer_id)
  numericCheck(digits)
  palette <- paletteCheck(palette)

  infoWindowChart <- NULL
  if (!is.null(info_window) && isInfoWindowChart(info_window)) {
    infoWindowChart <- info_window
    objArgs[['info_window']] <- NULL
  }

  allCols <- circleColumns()
  requiredCols <- requiredCircleColumns()
  colourColumns <- shapeAttributes(fill_colour, stroke_colour)

  shape <- createMapObject(data, allCols, objArgs)
  pal <- createPalettes(shape, colourColumns)
  colour_palettes <- createColourPalettes(data, pal, colourColumns, palette)
  colours <- createColours(shape, colour_palettes)

  if(length(colours) > 0){
    shape <- replaceVariableColours(shape, colours)
  }

  ## LEGEND
  legend <- resolveLegend(legend, legend_options, colour_palettes)

  requiredDefaults <- setdiff(requiredCols, names(shape))
  if(length(requiredDefaults) > 0){
    shape <- addDefaults(shape, requiredDefaults, "circle")
  }

  shape <- createInfoWindowChart(shape, infoWindowChart, id)
  shape <- jsonlite::toJSON(shape, digits = digits)

  invoke_method(map, 'update_circles', shape, layer_id, legend)
}