S2 layer

NAMESPACE

@@ -64,6 +64,7 @@ export(add_mesh)
 export(add_path)
 export(add_pointcloud)
 export(add_polygon)
+export(add_s2)
 export(add_scatterplot)
 export(add_screengrid)
 export(add_sf)
@@ -88,6 +89,7 @@ export(clear_mesh)
 export(clear_path)
 export(clear_pointcloud)
 export(clear_polygon)
+export(clear_s2)
 export(clear_scatterplot)
 export(clear_screengrid)
 export(clear_terrain)

NEWS.md

@@ -1,3 +1,6 @@
+# v0.3.7
+* `add_s2` and `clear_s2` for adding S2 layers to the map [issue 395](https://github.com/SymbolixAU/mapdeck/issues/395)
+
 # v0.3.6
 
 * `add_legend` and `clear_legend()` for adding custom legends to the map [issue 390](https://github.com/SymbolixAU/mapdeck/issues/390)

R/map_layer_s2.R

@@ -0,0 +1,173 @@
+mapdeckS2Dependency <- function() {
+	list(
+		createHtmlDependency(
+			name = "s2",
+			version = "1.0.0",
+			src = system.file("htmlwidgets/lib/s2", package = "mapdeck"),
+			script = c("s2.js"),
+			all_files = FALSE
+		)
+	)
+}
+
+#' Add s2
+#'
+#' The S2 layer renders filled and/or stroked polygons based on the S2 
+#' geospatial indexing system.
+#'
+#' @inheritParams add_polygon
+#' @param token column of \code{data} containing the s2 tokens
+#'
+#' @section transitions:
+#'
+#' The transitions argument lets you specify the time it will take for the shapes to transition
+#' from one state to the next. Only works in an interactive environment (Shiny)
+#' and on WebGL-2 supported browsers and hardware.
+#'
+#' The time is in milliseconds
+#'
+#' Available transitions for s2
+#'
+#' list(
+#' elevation = 0
+#' colour = 0
+#' )
+#'
+#' @examples
+#' \dontrun{
+#'
+#' ## You need a valid access token from Mapbox
+#' key <- 'abc'
+#' set_token( key )
+#'
+#' mapdeck(
+#'  style = mapdeck_style("dark")
+#'  , location = c(-122.4, 37.8)
+#'  , zoom = 10
+#'  , pitch = 60
+#'  ) %>%
+#'  add_s2(
+#'    data = s2
+#'    , token = "token"
+#'    , fill_colour = "value"
+#'    , auto_highlight = TRUE
+#'    , legend = TRUE
+#'    , elevation = "value"
+#'    , elevation_scale = 1000
+#'    , palette = colourvalues::get_palette("inferno")
+#'    )
+#'
+#' }
+#'
+#' @details
+#'
+#' \code{add_s2} supports a data.frame with a column of s2 tokens
+#'
+#'
+#' @export
+add_s2 <- function(
+	map,
+	data = get_map_data(map),
+	token = NULL,
+	stroke_colour = NULL,
+	stroke_width = NULL,
+	stroke_opacity = NULL,
+	fill_colour = NULL,
+	fill_opacity = NULL,
+	elevation = NULL,
+	tooltip = NULL,
+	auto_highlight = FALSE,
+	elevation_scale = 1,
+	highlight_colour = "#AAFFFFFF",
+	light_settings = list(),
+	layer_id = NULL,
+	id = NULL,
+	palette = "viridis",
+	na_colour = "#808080FF",
+	legend = FALSE,
+	legend_options = NULL,
+	legend_format = NULL,
+	update_view = TRUE,
+	focus_layer = FALSE,
+	transitions = NULL
+) {
+
+	l <- list()
+	l[["token"]] <- force( token )
+	l[["stroke_colour"]] <- force( stroke_colour )
+	l[["stroke_width"]] <- force( stroke_width )
+	l[["stroke_opacity"]] <- resolve_opacity( stroke_opacity )
+	l[["fill_colour"]] <- force( fill_colour )
+	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
+	l[["elevation"]] <- force( elevation )
+	l[["tooltip"]] <- force( tooltip )
+	l[["id"]] <- force( id )
+	l[["na_colour"]] <- force( na_colour )
+
+	l <- resolve_palette( l, palette )
+	l <- resolve_legend( l, legend )
+	l <- resolve_legend_options( l, legend_options )
+
+	# l <- resolve_data( data, l, c("POINT","MULTIPOINT") )
+	l[["data_type"]] <- "df"
+	l[["data"]] <- data
+
+	bbox <- init_bbox()
+	update_view <- force( update_view )
+	focus_layer <- force( focus_layer )
+
+	is_extruded <- TRUE
+	if( !is.null( l[["stroke_width"]] ) | !is.null( l[["stroke_colour"]] ) ) {
+		is_extruded <- FALSE
+		if( !is.null( elevation ) ) {
+			message("stroke provided, ignoring elevation")
+		}
+		if( is.null( l[["stroke_width"]] ) ) {
+			l[["stroke_width"]] <- 1L
+		}
+	}
+
+	if ( !is.null(l[["data"]]) ) {
+		data <- l[["data"]]
+		l[["data"]] <- NULL
+	}
+
+	checkHexAlpha(highlight_colour)
+	layer_id <- layerId(layer_id, "s2")
+
+	map <- addDependency(map, mapdeckS2Dependency())
+
+	tp <- l[["data_type"]]
+	l[["data_type"]] <- NULL
+
+	geometry_column <- "token"
+
+	## use 'polyline' method because we have strings (tokens), not lat/lon coordinates
+	shape <- rcpp_point_polyline( data, l, geometry_column, "s2")
+
+	jsfunc <- "add_s2"
+
+	light_settings <- jsonify::to_json(light_settings, unbox = T)
+	js_transitions <- resolve_transitions(transitions, "polygon")
+
+	if( inherits( legend, "json" ) ) {
+		shape[["legend"]] <- legend
+		legend_format <- "hex"
+	} else {
+		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
+		legend_format <- "rgb"
+	}
+
+	invoke_method(
+		map, jsfunc, map_type( map ), shape[["data"]], layer_id, light_settings,
+		elevation_scale, auto_highlight, highlight_colour, shape[["legend"]], legend_format,
+		js_transitions, is_extruded
+	)
+}
+
+#' @rdname clear
+#' @export
+clear_s2 <- function(map, layer_id = NULL, update_view = TRUE, clear_legend = TRUE) {
+	layer_id <- layerId(layer_id, "s2")
+	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "s2", update_view, clear_legend )
+}

R/mapdeck_map_utilities.R

@@ -141,6 +141,7 @@ layerId <- function(
 		, "path"
 		, "pointcloud"
 		, "polygon"
+		, "s2"
 		, "scatterplot"
 		, "screengrid"
 		, "terrain"

data-raw/s2.R

@@ -0,0 +1,8 @@
+
+
+df <- jsonify::from_json("https://raw.githubusercontent.com/visgl/deck.gl-data/master/website/sf.s2cells.json")
+
+s2 <- as.data.frame(df)
+
+usethis::use_data(s2, overwrite = TRUE)
+

inst/htmlwidgets/lib/s2/s2.js

@@ -0,0 +1,41 @@
+function add_s2( map_id, map_type, s2_data, layer_id, light_settings, elevation_scale, auto_highlight, highlight_colour, legend, legend_format, js_transition, is_extruded ) {
+//bbox, update_view, focus_layer,
+
+  console.log( legend );
+
+  const s2Layer = new deck.S2Layer({
+  	map_id: map_id,
+    id: 's2-'+layer_id,
+    data: s2_data,
+    pickable: true,
+    stroked: true,
+    filled: true,
+    wireframe: false,
+    extruded: is_extruded,
+    lineWidthMinPixels: 0,
+    getS2Token: d => d.token,
+    getLineColor: d => d.stroke_colour,
+    getFillColor: d => d.fill_colour,
+    getLineWidth: d => d.stroke_width,
+    getElevation: d => d.elevation,
+    elevationScale: elevation_scale,
+    lightSettings: light_settings,
+    autoHighlight: auto_highlight,
+    highlightColor: md_hexToRGBA( highlight_colour ),
+    onHover: md_update_tooltip,
+    onClick: info => md_layer_click( map_id, "s2", info ),
+    transitions: js_transition || {}
+  });
+
+  if( map_type == "google_map") {
+    md_update_overlay( map_id, 's2-'+layer_id, s2Layer );
+  } else {
+	  md_update_layer( map_id, 's2-'+layer_id, s2Layer );
+  }
+
+	if (legend !== false) {
+	  md_add_legend(map_id, map_type, layer_id, legend, legend_format);
+	}
+
+	// md_layer_view( map_id, map_type, layer_id, focus_layer, bbox, update_view );
+}