R/google_map_layer_polyline.R

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

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


#' Add polyline
#'
#' Add a polyline to a google map
#'
#' @inheritParams add_polygons
#' @param geodesic logical
#'
#' @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
#'
#' @note The lines can be generated by either using an encoded polyline, or by a
#' set of lat/lon coordinates.
#' You sould specify either the column containing an encoded polyline, OR the
#' lat / lon colulmns.
#'
#' Using \code{update_map_view = TRUE} for multiple polylines may be slow, so it
#' may be more appropriate to set the view of the map using the location argument
#' of \code{google_map()}
#'
#' @inheritSection add_circles palette
#'
#' @examples
#' \dontrun{
#'
#' ## using lat/lon coordinates
#'
#' set_key("your_api_key")
#'
#' google_map(data = tram_route) %>%
#'   add_polylines(lat = "shape_pt_lat", lon = "shape_pt_lon")
#'
#'
#' google_map() %>%
#'   add_polylines(data = melbourne, polyline = "polyline", stroke_weight = 1,
#'       stroke_colour = "SA4_NAME")
#'
#' ## using encoded polyline and various colour / fill options
#' url <- 'https://raw.githubusercontent.com/plotly/datasets/master/2011_february_aa_flight_paths.csv'
#' flights <- read.csv(url)
#' flights$id <- seq_len(nrow(flights))
#'
#'
#' ## encode the routes as polylines
#' lst <- lapply(unique(flights$id), function(x){
#'   lat = c(flights[flights["id"] == x, c("start_lat")], flights[flights["id"] == x, c("end_lat")])
#'   lon = c(flights[flights["id"] == x, c("start_lon")], flights[flights["id"] == x, c("end_lon")])
#'   data.frame(id = x, polyline = encode_pl(lat = lat, lon = lon))
#' })
#'
#' flights <- merge(flights, do.call(rbind, lst), by = "id")
#'
#' style <- map_styles()$night
#'
#' google_map(key = map_key, style = style) %>%
#'   add_polylines(data = flights, polyline = "polyline", mouse_over_group = "airport1",
#'                stroke_weight = 1, stroke_opacity = 0.3, stroke_colour = "#ccffff")
#'
#'
#' }
#' @export
add_polylines <- function(map,
                          data = get_map_data(map),
                          polyline = NULL,
                          lat = NULL,
                          lon = NULL,
                          id = NULL,
                          geodesic = NULL,
                          stroke_colour = NULL,
                          stroke_weight = NULL,
                          stroke_opacity = NULL,
                          info_window = NULL,
                          mouse_over = NULL,
                          mouse_over_group = NULL,
                          draggable = NULL,
                          editable = NULL,
                          update_map_view = TRUE,
                          layer_id = NULL,
                          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[["polyline"]] <- force( polyline )
  objArgs[["lat"]] <- force( lat )
  objArgs[["lon"]] <- force( lon )
  objArgs[["id"]] <- force( id )
  objArgs[["geodesic"]] <- force( geodesic )
  objArgs[["stroke_colour"]] <- force( stroke_colour )
  objArgs[["stroke_weight"]] <- force( stroke_weight )
  objArgs[["stroke_opacity"]] <- force( stroke_opacity )
  objArgs[["info_window"]] <- force( info_window )
  objArgs[["mouse_over"]] <- force( mouse_over )
  objArgs[["mouse_over_group"]] <- force( mouse_over_group )
  objArgs[["draggable"]] <- force( draggable )
  objArgs[["editable"]] <- force( editable )
  objArgs[["update_map_view"]] <- force( update_map_view )
  objArgs[["layer_id"]] <- force( layer_id )
  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, "LINESTRING")
  polyline <- findEncodedColumn(data, polyline)

  ## - if sf object, and geometry column has not been supplied, it needs to be
  ## added to objArgs after the match.call() function
  if( !is.null(polyline) && !polyline %in% names(objArgs) ) {
    objArgs[['polyline']] <- polyline
  }

  ## PARAMETER CHECKS
  if(!dataCheck(data, "add_polyline")) data <- polylineDefaults(1)

  layer_id <- layerId(layer_id)
  latLonPolyCheck(lat, lon, polyline)

  usePolyline <- isUsingPolyline(polyline)

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

  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)

  lst <- polyIdCheck(data, id, usePolyline, objArgs)
  data <- lst$data
  objArgs <- lst$objArgs
  id <- lst$id
  objArgs <- zIndexCheck( objArgs, z_index )
  ## END PARAMETER CHECKS

  allCols <- polylineColumns()
  requiredCols <- requiredLineColumns()
  colourColumns <- lineAttributes(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, "polyline")
  }

  if (usePolyline) {

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

  } else {

    ids <- unique(shape[, 'id'])
    n <- names(shape)[names(shape) %in% objectColumns("polylineCoords")]
    keep <- setdiff(n, c('id', 'lat', 'lng'))

    lst_polyline <- objPolylineCoords(shape, ids, keep)

    lst_polyline <- createInfoWindowChart(lst_polyline, infoWindowChart, id)

    shape <- jsonlite::toJSON(lst_polyline, digits = digits, auto_unbox = T)
  }

  map <- addDependency(map, googlePolylineDependency())

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


#' Update polylines
#'
#' Updates specific attributes of polylines. Designed to be
#' used in a shiny application.
#'
#' @note Any polylines (as specified by the \code{id} argument) that do not exist
#' in the \code{data} passed into \code{add_polylines()} will not be added to the
#' map. This function will only update the polylines that currently exist on
#' the map when the function is called.
#'
#' @inheritParams update_polygons
#'
#' @examples
#' \dontrun{
#'
#' map_key <- 'your_api_key'
#'
#' ## coordinate columns
#' ## plot polylines using default attributes
#' df <- tram_route
#' df$id <- c(rep(1, 27), rep(2, 28))
#'
#' df$colour <- c(rep("#00FFFF", 27), rep("#FF00FF", 28))
#'
#' google_map(key = map_key) %>%
#'   add_polylines(data = df, lat = 'shape_pt_lat', lon = 'shape_pt_lon',
#'                 stroke_colour = "colour", id = 'id')
#'
#' ## specify width and colour attributes to update
#' df_update <- data.frame(id = c(1,2),
#'                         width = c(3,10),
#'                         colour = c("#00FF00", "#DCAB00"))
#'
#' google_map(key = map_key) %>%
#'   add_polylines(data = df, lat = 'shape_pt_lat', lon = 'shape_pt_lon',
#'                 stroke_colour = "colour", id = 'id') %>%
#'   update_polylines(data = df_update, id = 'id', stroke_weight = "width",
#'                    stroke_colour = 'colour')
#'
#'
#' ## encoded polylines
#' pl <- sapply(unique(df$id), function(x){
#'   encode_pl(lat = df[ df$id == x , 'shape_pt_lat'], lon = df[ df$id == x, 'shape_pt_lon'])
#' })
#'
#' df <- data.frame(id = c(1, 2), polyline = pl)
#'
#' df_update <- data.frame(id = c(1,2),
#'                         width = c(3,10),
#'                         var = c("a","b"))
#'
#' google_map(key = map_key) %>%
#'   add_polylines(data = df, polyline = 'polyline')
#'
#' google_map(key = map_key) %>%
#'   add_polylines(data = df, polyline = 'polyline') %>%
#'   update_polylines(data = df_update, id = 'id', stroke_weight = "width",
#'                    stroke_colour = 'var')
#'
#' }
#'
#' @export
update_polylines <- function(map, data, id,
                             stroke_colour = NULL,
                             stroke_weight = NULL,
                             stroke_opacity = NULL,
                             info_window = NULL,
                             layer_id = NULL,
                             palette = NULL,
                             legend = F,
                             legend_options = NULL
                             ){

  #objArgs <- match.call(expand.dots = F)
  objArgs <- list()
  objArgs[["id"]] <- force( id )
  objArgs[["stroke_colour"]] <- force( stroke_colour )
  objArgs[["stroke_weight"]] <- force( stroke_weight )
  objArgs[["stroke_opacity"]] <- force( stroke_opacity )
  objArgs[["info_window"]] <- force( info_window )
  objArgs[["layer_id"]] <- force( layer_id )
  objArgs[["palette"]] <- force( palette )
  objArgs[["legend"]] <- force( legend )
  objArgs[["legend_options"]] <- force( legend_options )

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


  if(!dataCheck(data, "update_polylines")) data <- polylineUpdateDefaults(1)
  layer_id <- layerId(layer_id)

  palette <- paletteCheck(palette)

  lst <- polyIdCheck(data, id, FALSE, objArgs)
  data <- lst$data
  objArgs <- lst$objArgs
  id <- lst$id

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

  ## we can only update shapes that already exist with new attributes
  allCols <- polylineUpdateColumns()
  requiredCols <- requiredLineUpdateColumns()
  colourColumns <- lineAttributes(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, "polylineUpdate")
  }

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

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


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