close #211

DESCRIPTION

@@ -43,4 +43,5 @@ LinkingTo:
     jsonify,
     rapidjsonr,
     Rcpp,
+    sfheaders,
     spatialwidget (>= 0.2.1005)

NAMESPACE

@@ -49,6 +49,7 @@ export(add_dependencies)
 export(add_geojson)
 export(add_greatcircle)
 export(add_grid)
+export(add_heatmap)
 export(add_hexagon)
 export(add_line)
 export(add_mesh)
@@ -68,6 +69,7 @@ export(clear_column)
 export(clear_geojson)
 export(clear_greatcircle)
 export(clear_grid)
+export(clear_heatmap)
 export(clear_hexagon)
 export(clear_legend)
 export(clear_line)
@@ -94,6 +96,7 @@ export(mapdeck_update)
 export(mapdeck_view)
 export(renderMapdeck)
 export(set_token)
+export(update_style)
 import(htmlwidgets)
 importFrom(Rcpp,sourceCpp)
 importFrom(magrittr,"%>%")

NEWS.md

@@ -1,6 +1,8 @@
 # mapdeck 0.3
 
 * input$map_view_change now observed [issue211](https://github.com/SymbolixAU/mapdeck/issues/211) - thanks @zacdav
+* `update_stype()` function
+* `add_path()` accepts dashed lines
 * mapbox tokens are searched for in environement variables if one isn't provided [issue209](https://github.com/SymbolixAU/mapdeck/issues/209)
 * z-fighting [issue 199](https://github.com/SymbolixAU/mapdeck/issues/199)
 * factors correctly used in legends [issue #138](https://github.com/SymbolixAU/mapdeck/issues/138)

R/RcppExports.R

@@ -53,6 +53,18 @@ rcpp_grid_polyline <- function(data, params, geometry_columns) {
     .Call(`_mapdeck_rcpp_grid_polyline`, data, params, geometry_columns)
 }
 
+rcpp_heatmap_geojson <- function(data, params, geometry_columns, digits) {
+    .Call(`_mapdeck_rcpp_heatmap_geojson`, data, params, geometry_columns, digits)
+}
+
+rcpp_heatmap_geojson_df <- function(data, params, geometry_columns, digits) {
+    .Call(`_mapdeck_rcpp_heatmap_geojson_df`, data, params, geometry_columns, digits)
+}
+
+rcpp_heatmap_polyline <- function(data, params, geometry_columns) {
+    .Call(`_mapdeck_rcpp_heatmap_polyline`, data, params, geometry_columns)
+}
+
 rcpp_hexagon_geojson <- function(data, params, geometry_columns, digits) {
     .Call(`_mapdeck_rcpp_hexagon_geojson`, data, params, geometry_columns, digits)
 }

R/map_layer_column.R

@@ -24,6 +24,7 @@ mapdeckColumnDependency <- function() {
 #' The disk is a regular polygon that fits inside the given radius.
 #' A higher resolution will yield a smoother look close-up, but also requires more resources to render.
 #' @param radius in metres. Default 1000
+#' @param angle disk rotation, counter-clockwise, in degrees
 #' @param coverage radius multiplier, in range [0,1]. The radius of the disk is calcualted
 #' by coverage * radius
 #' @param elevation_scale value to scale the elevations of the columns Default 1

R/map_layer_geojson.R

@@ -22,11 +22,24 @@ mapdeckGeojsonDependency <- function() {
 #' @param stroke_colour column of an \code{sf} object, or field inside a GeoJSON \code{property} to use for colour
 #' @param stroke_opacity column of an \code{sf} object, or field inside a GeoJSON \code{property} to use for opacity
 #' @param stroke_width column of an \code{sf} object, or field inside a GeoJSON \code{property} to use for width (in meters)
+#' @param dash_size size of each dash, relative to the width of the stroke
+#' @param dash_gap size of the gap between dashes, relative to the width of the stroke
 #' @param fill_colour column of an \code{sf} object, or field inside a GeoJSON \code{property} to use for colour
 #' @param fill_opacity column of an \code{sf} object, or field inside a GeoJSON \code{property} to use for opacity
 #' @param radius radius of points in meters. Default 1. See details
 #' @param elevation elevation of polygons. Default 0. See details
 #' @param light_settings list of light setting parameters. See \link{light_settings}
+#' @param line_width_units The units of the line width, one of 'meters', 'pixels'.
+#' When zooming in and out, meter sizes scale with the base map, and pixel sizes remain the same on screen.
+#' @param line_width_scale The line width multiplier that multiplied to all lines,
+#' including the LineString and MultiLineString features and also the outline for
+#' Polygon and MultiPolygon features if the stroked attribute is true
+#' @param line_width_min_pixels The minimum line width in pixels.
+#' @param elevation_scale Elevation multiplier. The final elevation is calculated by
+#' elevationScale * getElevation(d). elevationScale is a handy property to scale
+#' all polygon elevation without updating the data
+#' @param point_radius_scale A global radius multiplier for all points.
+#' @param point_radius_min_pixels The minimum radius in pixels.
 #' @param tooltip variable of \code{data} containing text or HTML to render as a tooltip.
 #' Only works on \code{sf} objects.
 #' @param legend either a logical indiciating if the legend(s) should be displayed, or
@@ -188,6 +201,8 @@ add_geojson <- function(
 	stroke_colour = NULL,
 	stroke_opacity = NULL,
 	stroke_width = NULL,
+	dash_size = NULL,
+	dash_gap = NULL,
 	fill_colour = NULL,
 	fill_opacity = NULL,
 	radius = NULL,
@@ -201,6 +216,12 @@ add_geojson <- function(
 	highlight_colour = "#AAFFFFFF",
 	palette = "viridis",
 	na_colour = "#808080FF",
+	line_width_units = c("metres", "pixels"),
+	line_width_scale = 1,
+	line_width_min_pixels = 0,
+	elevation_scale = 1,
+	point_radius_scale = 1,
+	point_radius_min_pixels = 1,
 	update_view = TRUE,
 	focus_layer = FALSE,
 	digits = 6,
@@ -211,6 +232,8 @@ add_geojson <- function(
 	l[["stroke_colour"]] <- force( stroke_colour )
 	l[["stroke_opacity"]] <- force( stroke_opacity )
 	l[["stroke_width"]] <- force( stroke_width )
+	l[["dash_size"]] <- force(dash_size)
+	l[["dash_gap"]] <- force(dash_gap)
 	l[["fill_colour"]] <- force( fill_colour )
 	l[["fill_opacity"]] <- force( fill_opacity )
 	l[["elevation"]] <- force( elevation )
@@ -227,6 +250,8 @@ add_geojson <- function(
 		!is.null( l[["stroke_colour"]] ) |
 		!is.null( l[["stroke_opacity"]] ) |
 		!is.null( l[["stroke_width"]] ) |
+		!is.null( l[["dash_size"]] ) |
+		!is.null( l[["dash_gap"]] ) |
 		!is.null( l[["fill_colour"]] ) |
 		!is.null( l[["fill_opacity"]] ) |
 		!is.null( l[["elevation"]] ) |
@@ -243,6 +268,8 @@ add_geojson <- function(
 	l <- resolve_legend_options( l, legend_options )
 	l <- resolve_geojson_data( data, l )
 
+	line_width_units <- match.arg(line_width_units)
+
 	if( !is.null(l[["data"]] ) ) {
 		data <- l[["data"]]
 		l[["data"]] <- NULL
@@ -282,7 +309,8 @@ add_geojson <- function(
 	invoke_method(
 		map, jsfunc, map_type( map ), shape[["data"]], layer_id, light_settings, auto_highlight,
 		highlight_colour, shape[["legend"]], bbox, update_view, focus_layer,
-		js_transitions
+		js_transitions, line_width_units, line_width_scale, line_width_min_pixels,
+		elevation_scale, point_radius_scale, point_radius_min_pixels
 		)
 }
 

R/map_layer_heatmap.R

@@ -0,0 +1,170 @@
+mapdeckHeatmapDependency <- function() {
+	list(
+		createHtmlDependency(
+			name = "heatmap",
+			version = "1.0.0",
+			src = system.file("htmlwidgets/lib/heatmap", package = "mapdeck"),
+			script = c("heatmap.js"),
+			all_files = FALSE
+		)
+	)
+}
+
+
+#' Add Heatmap
+#'
+#' The Heatmap Layer can be used to visualise spatial distribution of data.
+#' It implements Gaussian Kernel Density Estimation to render the heatmaps.
+#'
+#' @section note:
+#'
+#' The current version of this layer is supported only for WebGL2 enabled browswers
+#' So you may find it doesn't render in the RStudio viewer.
+#'
+#' @inheritParams add_polygon
+#' @param lon column containing longitude values
+#' @param lat column containing latitude values
+#' @param weight the weight of each value. Default 1
+#' @param colour_range vector of 6 hex colours
+#' @param radius_pixels Radius of the circle in pixels, to which the weight of an object is distributed
+#' @param intensity Value that is multiplied with the total weight at a pixel to
+#' obtain the final weight. A value larger than 1 biases the output color towards
+#' the higher end of the spectrum, and a value less than 1 biases the output
+#' color towards the lower end of the spectrum
+#' @param threshold The HeatmapLayer reduces the opacity of the pixels with relatively
+#' low weight to create a fading effect at the edge.
+#' A larger threshold smoothens the boundaries of color blobs, while making pixels
+#' with low relative weight harder to spot (due to low alpha value).
+#' Threshold is defined as the ratio of the fading weight to the max weight, between 0 and 1.
+#' For example, 0.1 affects all pixels with weight under 10\% of the max.
+#'
+#' @inheritSection add_polygon data
+#'
+#' @examples
+#' \donttest{
+#'
+#' ## You need a valid access token from Mapbox
+#' key <- 'abc'
+#' set_token( key )
+#'
+#' df <- read.csv(paste0(
+#' 'https://raw.githubusercontent.com/uber-common/deck.gl-data/master/',
+#' 'examples/3d-heatmap/heatmap-data.csv'
+#' ))
+#'
+#' df <- df[ !is.na(df$lng), ]
+#' df$weight <- sample(1:10, size = nrow(df), replace = T)
+#'
+#' mapdeck( style = mapdeck_style('dark'), pitch = 45 ) %>%
+#' add_heatmap(
+#'   data = df
+#'   , lat = "lat"
+#'   , lon = "lng"
+#'   , weight = "weight",
+#'   , layer_id = "heatmap_layer"
+#' )
+#'
+#' ## as an sf object
+#' library(sf)
+#' sf <- sf::st_as_sf( df, coords = c("lng", "lat"))
+#' mapdeck( token = key, style = mapdeck_style('dark'), pitch = 45 ) %>%
+#' add_heatmap(
+#'   data = sf
+#'   , weight = "weight",
+#'   , layer_id = "heatmap_layer"
+#' )
+#'
+#' }
+#'
+#' @details
+#'
+#' \code{add_heatmap} supports POINT and MULTIPOINT sf objects
+#'
+#' @export
+add_heatmap <- function(
+	map,
+	data = get_map_data(map),
+	lon = NULL,
+	lat = NULL,
+	polyline = NULL,
+	weight = NULL,
+	colour_range = NULL,
+	radius_pixels = 30,
+	intensity = 1,
+	threshold = 0.05,
+	layer_id = NULL,
+	update_view = TRUE,
+	focus_layer = FALSE,
+	digits = 6
+) {
+
+	experimental_layer("heatmap")
+
+	l <- list()
+	l[["polyline"]] <- force( polyline )
+	l[["weight"]] <- force( weight )
+	l[["lon"]] <- force( lon )
+	l[["lat"]] <- force( lat )
+
+	l <- resolve_data( data, l, c("POINT","MULTIPOINT") )
+
+	bbox <- init_bbox()
+	update_view <- force( update_view )
+	focus_layer <- force( focus_layer )
+
+	if ( !is.null(l[["data"]]) ) {
+		data <- l[["data"]]
+		l[["data"]] <- NULL
+	}
+
+	if( !is.null(l[["bbox"]] ) ) {
+		bbox <- l[["bbox"]]
+		l[["bbox"]] <- NULL
+	}
+
+	## parmater checks
+	#usePolyline <- isUsingPolyline(polyline)
+	layer_id <- layerId(layer_id, "heatmap")
+
+	if( is.null( colour_range ) ) {
+		colour_range <- colourvalues::colour_values(1:6, palette = "viridis")
+	}
+
+	if(length(colour_range) != 6)
+		stop("mapdeck - colour_range must have 6 hex colours")
+	## end parameter checks
+
+	checkHex(colour_range)
+
+	map <- addDependency(map, mapdeckHeatmapDependency())
+
+	tp <- l[["data_type"]]
+	l[["data_type"]] <- NULL
+
+	jsfunc <- "add_heatmap_geo"
+	if( tp == "sf" ) {
+		geometry_column <- c( "geometry" )
+		shape <- rcpp_heatmap_geojson( data, l, geometry_column, digits )
+	} else if ( tp == "df" ) {
+		geometry_column <- list( geometry = c("lon", "lat") )
+		shape <- rcpp_heatmap_geojson_df( data, l, geometry_column, digits )
+	} else if ( tp == "sfencoded" ) {
+		geometry_column <- "polyline"
+		shape <- rcpp_heatmap_polyline( data, l, geometry_column )
+		jsfunc <- "add_heatmap_polyline"
+	}
+
+	invoke_method(
+		map, jsfunc, map_type( map ), shape[["data"]], layer_id, colour_range,
+		radius_pixels, intensity, threshold, bbox, update_view, focus_layer
+	)
+}
+
+
+#' @rdname clear
+#' @export
+clear_heatmap <- function( map, layer_id = NULL) {
+	layer_id <- layerId(layer_id, "heatmap")
+	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "heatmap" )
+}
+

R/map_layer_mesh.R

@@ -67,7 +67,7 @@ add_mesh <- function(
 	l <- list()
 	# fill_colour = "average_z"
 	# fill_colour = "z"
-	l[["fill_colour"]] <- force( fill_colour )
+	# l[["fill_colour"]] <- force( fill_colour )
 	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
 	l[["elevation"]] <- force( elevation )
 	l[["tooltip"]] <- force( tooltip )
@@ -130,7 +130,7 @@ add_mesh <- function(
 		# geometry_column <- c( "geometry" )
 		geometry_column <- c( vertex, index )
 		shape <- rcpp_mesh_geojson( data, l, geometry_column, digits )
-		return( shape )
+		#return( shape )
 	}
 
 	#	geometry_column <- c( "geometry" ) ## This is where we woudl also specify 'origin' or 'destination'
@@ -255,8 +255,8 @@ add_mesh2 <- function(
 		# geometry_column <- c( "geometry" )
 		geometry_column <- c( vertex, index )
 		shape <- rcpp_mesh_geojson2( data, geometry_column )
-		return( shape )
-		shape[["legend"]] <- list()
+		# return( shape )
+		# shape[["legend"]] <- list()
 	}
 
 	#	geometry_column <- c( "geometry" ) ## This is where we woudl also specify 'origin' or 'destination'

R/map_layer_path.R

@@ -18,6 +18,8 @@ mapdeckPathDependency <- function() {
 #'
 #' @inheritParams add_polygon
 #' @param stroke_width width of the stroke in meters. Default 1.
+#' @param dash_size size of each dash, relative to the width of the stroke
+#' @param dash_gap size of the gap between dashes, relative to the width of the stroke
 #' @param billboard logical indicating if the path always faces the camera (TRUE) or
 #' if it always faces up (FALSE)
 #'
@@ -75,6 +77,8 @@ add_path <- function(
 	stroke_colour = NULL,
 	stroke_width = NULL,
 	stroke_opacity = NULL,
+	dash_size = NULL,
+	dash_gap = NULL,
 	tooltip = NULL,
 	billboard = FALSE,
 	layer_id = NULL,
@@ -97,6 +101,8 @@ add_path <- function(
 	l[["stroke_colour"]] <- force( stroke_colour)
 	l[["stroke_width"]] <- force( stroke_width )
 	l[["stroke_opacity"]] <- resolve_opacity( stroke_opacity )
+	l[["dash_size"]] <- force(dash_size)
+	l[["dash_gap"]] <- force(dash_gap)
 	l[["tooltip"]] <- force(tooltip)
 	l[["id"]] <- force(id)
 	l[["na_colour"]] <- force(na_colour)

R/map_layer_screengrid.R

@@ -45,7 +45,7 @@ mapdeckScreengridDependency <- function() {
 #'
 #' mapdeck( style = mapdeck_style('dark'), pitch = 45 ) %>%
 #' add_screengrid(
-#'   data = df[1:1000, ]
+#'   data = df
 #'   , lat = "lat"
 #'   , lon = "lng"
 #'   , weight = "weight",