SymbolixAU / mapdeck
1
mapdeckPolygonDependency <- function() {
2 1
	list(
3 1
		createHtmlDependency(
4 1
			name = "polygon",
5 1
			version = "1.0.0",
6 1
			src = system.file("htmlwidgets/lib/polygon", package = "mapdeck"),
7 1
			script = c("polygon.js"),
8 1
			all_files = FALSE
9
		)
10
	)
11
}
12

13

14
#' Add Polygon
15
#'
16
#' The Polygon Layer renders filled and/or stroked polygons.
17
#'
18
#' @inheritParams add_arc
19
#' @inheritParams add_line
20
#'
21
#' @param polyline optional column of \code{data} containing the polylines, if using encoded polylines
22
#' @param fill_colour column of \code{data} or hex colour for the fill colour.
23
#' If using a hex colour, use either a single value, or a column of hex colours  on \code{data}
24
#' @param fill_opacity Either a string specifying the column of \code{data}
25
#' containing the opacity of each shape, or a single value in [0,255], or [0, 1),
26
#' to be applied to all the shapes. Default 255. If a hex-string is used as the
27
#' colour, this argument is ignored and you should include the alpha on the hex string
28
#' @param stroke_colour variable of \code{data} or hex colour for the stroke. If used,
29
#' \code{elevation} is ignored.
30
#' If using a hex colour, use either a single value, or a column of hex colours  on \code{data}
31
#' @param stroke_width width of the stroke in meters. If used, \code{elevation} is ignored. Default 1.
32
#' @param light_settings list of light setting parameters. See \link{light_settings}
33
#' @param elevation the height the polygon extrudes from the map. Only available if neither
34
#' \code{stroke_colour} or \code{stroke_width} are supplied. Default 0
35
#' @param elevation_scale elevation multiplier.
36
#'
37
#' @section data:
38
#'
39
#' If the \code{data} is a simple feature object, the geometry column is automatically
40
#' detected. If the sf object contains more than one geometry column and you want to use a specific one,
41
#' you'll need to set the active geometry using \code{sf::st_geometry( x ) <- "your_column" },
42
#' where \code{"your_column"} is the name of the column you're activating. See \code{?sf::st_geometry}
43
#'
44
#'
45
#' @inheritSection add_arc legend
46
#' @inheritSection add_arc id
47
#'
48
#' @section transitions:
49
#'
50
#' The transitions argument lets you specify the time it will take for the shapes to transition
51
#' from one state to the next. Only works in an interactive environment (Shiny)
52
#' and on WebGL-2 supported browsers and hardware.
53
#'
54
#' The time is in milliseconds
55
#'
56
#' Available transitions for polygon
57
#'
58
#' list(
59
#' polygon = 0,
60
#' fill_colour = 0,
61
#' stroke_colour = 0,
62
#' stroke_width = 0,
63
#' elevation = 0
64
#' )
65
#'
66
#' @examples
67
#' \donttest{
68
#'
69
#' ## You need a valid access token from Mapbox
70
#' key <- 'abc'
71
#' set_token( key )
72
#'
73
#' library(geojsonsf)
74
#'
75
#' sf <- geojsonsf::geojson_sf("https://symbolixau.github.io/data/geojson/SA2_2016_VIC.json")
76
#'
77
#' mapdeck(
78
#'   style = mapdeck_style('dark')
79
#' ) %>%
80
#'   add_polygon(
81
#'     data = sf
82
#'     , layer = "polygon_layer"
83
#'     , fill_colour = "SA2_NAME16"
84
#' )
85
#'
86
#' df <- melbourne  ## data.frame with encoded polylnies
87
#' df$elevation <- sample(100:5000, size = nrow(df))
88
#' df$info <- paste0("<b>SA2 - </b><br>",df$SA2_NAME)
89
#'
90
#' mapdeck(
91
#'   style = mapdeck_style('dark')
92
#'   , location = c(145, -38)
93
#'   , zoom = 8
94
#'   ) %>%
95
#'   add_polygon(
96
#'     data = df
97
#'     , polyline = "geometry"
98
#'     , layer = "polygon_layer"
99
#'     , fill_colour = "SA2_NAME"
100
#'     , elevation = "elevation"
101
#'     , tooltip = 'info'
102
#'     , legend = T
103
#'   )
104
#'
105
#' }
106
#'
107
#' @details
108
#'
109
#' \code{add_polygon} supports POLYGON and MULTIPOLYGON sf objects
110
#'
111
#' @export
112
add_polygon <- function(
113
	map,
114
	data = get_map_data(map),
115
	polyline = NULL,
116
	stroke_colour = NULL,
117
	stroke_width = NULL,
118
	stroke_opacity = NULL,
119
	fill_colour = NULL,
120
	fill_opacity = NULL,
121
	elevation = NULL,
122
	tooltip = NULL,
123
	auto_highlight = FALSE,
124
	elevation_scale = 1,
125
	highlight_colour = "#AAFFFFFF",
126
	light_settings = list(),
127
	layer_id = NULL,
128
	id = NULL,
129
	palette = "viridis",
130
	na_colour = "#808080FF",
131
	legend = FALSE,
132
	legend_options = NULL,
133
	legend_format = NULL,
134
	update_view = TRUE,
135
	focus_layer = FALSE,
136
	digits = 6,
137
	transitions = NULL,
138
	brush_radius = NULL
139
) {
140

141
	#if( is.null( stroke_colour )) stroke_colour <- fill_colour
142

143 1
	l <- list()
144 1
	l[["polyline"]] <- force( polyline )
145 1
	l[["stroke_colour"]] <- force( stroke_colour )
146 1
	l[["stroke_width"]] <- force( stroke_width )
147 1
	l[["stroke_opacity"]] <- resolve_opacity( stroke_opacity )
148 1
	l[["fill_colour"]] <- force( fill_colour )
149 1
	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
150 1
	l[["elevation"]] <- force( elevation )
151 1
	l[["tooltip"]] <- force( tooltip )
152 1
	l[["id"]] <- force( id )
153 1
	l[["na_colour"]] <- force( na_colour )
154

155 1
	l <- resolve_palette( l, palette )
156 1
	l <- resolve_legend( l, legend )
157 1
	l <- resolve_legend_options( l, legend_options )
158 1
	l <- resolve_data( data, l, c("POLYGON") )
159

160 1
	bbox <- init_bbox()
161 1
	update_view <- force( update_view )
162 1
	focus_layer <- force( focus_layer )
163 1
	elevation_scale <- force( elevation_scale )
164

165 1
	is_extruded <- FALSE
166
	## issue 287
167 1
	if( !is.null( elevation ) ) {
168 0
		is_extruded <- TRUE
169
	}
170 1
	if( !is.null( l[["stroke_width"]] ) | !is.null( l[["stroke_colour"]] ) ) {
171 0
		is_extruded <- FALSE
172 0
		if( !is.null( elevation ) ) {
173 0
			message("stroke provided, ignoring elevation")
174
		}
175 0
		if( is.null( l[["stroke_width"]] ) ) {
176 0
			l[["stroke_width"]] <- 1L
177
		}
178
	}
179

180 1
	if ( !is.null(l[["data"]]) ) {
181 1
		data <- l[["data"]]
182 1
		l[["data"]] <- NULL
183
	}
184

185
	## sf objects come with a bounding box
186 1
	if( !is.null(l[["bbox"]] ) ) {
187 0
		bbox <- l[["bbox"]]
188 0
		l[["bbox"]] <- NULL
189
	}
190

191 1
	checkHexAlpha(highlight_colour)
192 1
	layer_id <- layerId(layer_id, "polygon")
193

194 1
	map <- addDependency(map, mapdeckPolygonDependency())
195

196 1
	tp <- l[["data_type"]]
197 1
	l[["data_type"]] <- NULL
198

199 1
	jsfunc <- "add_polygon_geo"
200

201 1
	if ( tp == "sf" ) {
202 0
		geometry_column <- c( "geometry" ) ## This is where we woudl also specify 'origin' or 'destination'
203 0
		shape <- rcpp_polygon_geojson( data, l, geometry_column, digits )
204 1
	} else if ( tp == "sfencoded" ) {
205 1
		geometry_column <- "polyline"
206 1
		shape <- rcpp_polygon_polyline( data, l, geometry_column )
207 1
		jsfunc <- "add_polygon_polyline"
208
	# } else if ( tp == "mesh" ) {
209
	# 	geometry_column <- "geometry"
210
	# 	jsfunc <- "add_mesh"
211
	# 	shape <- rcpp_mesh_geojson( data, l, geometry_column )
212
	}
213

214 1
	light_settings <- jsonify::to_json(light_settings, unbox = T)
215 1
	js_transitions <- resolve_transitions( transitions, "polygon" )
216

217 1
	if( inherits( legend, "json" ) ) {
218 0
		shape[["legend"]] <- legend
219
	} else {
220 1
		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
221
	}
222

223 1
	invoke_method(
224 1
		map, jsfunc, map_type( map ), shape[["data"]], layer_id, light_settings,
225 1
		auto_highlight, highlight_colour, shape[["legend"]], bbox, update_view, focus_layer,
226 1
		js_transitions, is_extruded, elevation_scale, brush_radius
227
		)
228
}
229

230

231

232
#' @rdname clear
233
#' @export
234
clear_polygon <- function( map, layer_id = NULL) {
235 1
	layer_id <- layerId(layer_id, "polygon")
236 1
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "polygon" )
237
}
238

239

Read our documentation on viewing source code .

Loading