Nothing
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)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.