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

13

14

15
find_mesh_index <- function( data ) {
16
	 ## prefer triangles (in future maybe we do both)
17 0
	idx <- "it"
18 0
	if (!idx %in% names(data)) {
19 0
		idx <- "ib"
20
	}
21 0
	if (!idx %in% names(data)) stop("seems to be a malformed mesh3d,withno 'it' 'ib' array?")
22 0
	idx
23
}
24

25

26
#' Add Mesh
27
#'
28
#' Adds polygons to the map from a \code{mesh3d} object
29
#'
30
#' @inheritParams add_polygon
31
#'
32
#' @inheritSection add_arc legend
33
#' @inheritSection add_arc id
34
#'
35
#' @examples
36
#' \donttest{
37
#'
38
#' ## exaggerate the elevation slightly
39
#' m <- melbourne_mesh
40
#' m$vb[3, ] <- m$vb[3, ] * 50
41
#'
42
#'mapdeck() %>%
43
#'  add_mesh(
44
#'  data = m
45
#'  )
46
#'
47
#' }
48
#'
49
#' @details
50
#'
51
#' \code{add_mesh} supports mesh3d objects
52
#'
53
#' @export
54
add_mesh <- function(
55
	map,
56
	data = get_map_data(map),
57
	fill_opacity = NULL,
58
	elevation = NULL,
59
	tooltip = NULL,
60
	auto_highlight = FALSE,
61
	highlight_colour = "#AAFFFFFF",
62
	light_settings = list(),
63
	layer_id = NULL,
64
	id = NULL,
65
	palette = "viridis",
66
	na_colour = "#808080FF",
67
	legend = FALSE,
68
	legend_options = NULL,
69
	legend_format = NULL,
70
	update_view = TRUE,
71
	focus_layer = FALSE,
72
	digits = 6,
73
	transitions = NULL,
74
	brush_radius = NULL
75
) {
76

77
	#if( is.null( stroke_colour )) stroke_colour <- fill_colour
78 0
	experimental_layer( "mesh" )
79

80 0
	if(!inherits(data, "mesh3d")) {
81 0
		stop("mapdeck - expecting mesh3d object")
82
	}
83

84 0
	l <- list()
85 0
	fill_colour = "average_z"
86
	# fill_colour = "z"
87 0
	l[["fill_colour"]] <- force( fill_colour )
88 0
	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
89 0
	l[["elevation"]] <- force( elevation )
90 0
	l[["tooltip"]] <- force( tooltip )
91 0
	l[["id"]] <- force( id )
92 0
	l[["na_colour"]] <- force( na_colour )
93

94 0
	vertex <- "vb"
95 0
	index <- find_mesh_index( data )
96

97
	## check: need different checks for sense
98
	# if ( data[["primitivetype"]] == "quad" & is.null( data[["ib"]] ) ) {
99
	# 	stop("mapdeck - badly formed mesh3d type. Found quad and expecting ib index")
100
	# }
101
	# if ( data[["primitivetype"]] == "triangle" & is.null( data[["it"]] ) ) {
102
	# 	stop("mapdeck - badly formed mesh3d type. Found triangle and expecting it index")
103
	# }
104 0
	l <- resolve_palette( l, palette )
105 0
	l <- resolve_legend( l, legend )
106 0
	l <- resolve_legend_options( l, legend_options )
107

108 0
	l <- resolve_data( data, l, c("POLYGON") )
109

110 0
	bbox <- init_bbox()
111 0
	update_view <- force( update_view )
112 0
	focus_layer <- force( focus_layer )
113

114 0
	is_extruded <- TRUE
115
	# if( !is.null( l[["stroke_width"]] ) | !is.null( l[["stroke_colour"]] ) ) {
116
	# 	is_extruded <- FALSE
117
	# 	if( !is.null( elevation ) ) {
118
	# 		message("stroke provided, ignoring elevation")
119
	# 	}
120
	# 	if( is.null( l[["stroke_width"]] ) ) {
121
	# 		l[["stroke_width"]] <- 1L
122
	# 	}
123
	# }
124

125 0
	if ( !is.null(l[["data"]]) ) {
126 0
		data <- l[["data"]]
127 0
		l[["data"]] <- NULL
128
	}
129

130
	## sf objects come with a bounding box
131 0
	if( !is.null(l[["bbox"]] ) ) {
132 0
		bbox <- l[["bbox"]]
133 0
		l[["bbox"]] <- NULL
134
	}
135

136 0
	checkHexAlpha(highlight_colour)
137 0
	layer_id <- layerId(layer_id, "polygon")
138

139 0
	map <- addDependency(map, mapdeckMeshDependency())
140

141 0
	tp <- l[["data_type"]]
142 0
	l[["data_type"]] <- NULL
143

144 0
	jsfunc <- "add_mesh"
145

146 0
	if ( tp == "mesh" ) {
147
		# geometry_column <- c( "geometry" )
148 0
		geometry_column <- c( vertex, index )
149 0
		shape <- rcpp_mesh_geojson( data, l, geometry_column, digits )
150
		#return( shape )
151
	}
152

153
	#	geometry_column <- c( "geometry" ) ## This is where we woudl also specify 'origin' or 'destination'
154
	#	shape <- rcpp_polygon_geojson( data, l, geometry_column )
155
	# } else if ( tp == "sfencoded" ) {
156
	# 	geometry_column <- "polyline"
157
	# 	shape <- rcpp_polygon_polyline( data, l, geometry_column )
158
	# 	jsfunc <- "add_polygon_polyline"
159
	# }
160

161
	# return( shape )
162

163 0
	light_settings <- jsonify::to_json(light_settings, unbox = T)
164 0
	js_transitions <- resolve_transitions( transitions, "polygon" )
165

166 0
	if( inherits( legend, "json" ) ) {
167 0
		shape[["legend"]] <- legend
168
	} else {
169 0
		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
170
	}
171

172 0
	invoke_method(
173 0
		map, jsfunc, map_type( map ), shape[["data"]], layer_id, light_settings,
174 0
		auto_highlight, highlight_colour, shape[["legend"]], bbox, update_view, focus_layer,
175 0
		js_transitions, is_extruded, brush_radius
176
	)
177
}
178

179

180

181
# add_mesh2 <- function(
182
# 	map,
183
# 	data = get_map_data(map),
184
# 	fill_opacity = NULL,
185
# 	elevation = NULL,
186
# 	tooltip = NULL,
187
# 	auto_highlight = FALSE,
188
# 	highlight_colour = "#AAFFFFFF",
189
# 	light_settings = list(),
190
# 	layer_id = NULL,
191
# 	id = NULL,
192
# 	palette = "viridis",
193
# 	na_colour = "#808080FF",
194
# 	legend = FALSE,
195
# 	legend_options = NULL,
196
# 	legend_format = NULL,
197
# 	update_view = TRUE,
198
# 	focus_layer = FALSE,
199
# 	digits = 6,
200
# 	transitions = NULL
201
# ) {
202
#
203
# 	#if( is.null( stroke_colour )) stroke_colour <- fill_colour
204
# 	experimental_layer( "mesh" )
205
#
206
# 	if(!inherits(data, "mesh3d")) {
207
# 		stop("mapdeck - expecting mesh3d object")
208
# 	}
209
#
210
# 	l <- list()
211
# 	fill_colour = "average_z"
212
# 	l[["fill_colour"]] <- force( fill_colour )
213
# 	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
214
# 	l[["elevation"]] <- force( elevation )
215
# 	l[["tooltip"]] <- force( tooltip )
216
# 	l[["id"]] <- force( id )
217
# 	l[["na_colour"]] <- force( na_colour )
218
#
219
# 	vertex <- "vb"
220
# 	index <- find_mesh_index( data )
221
#
222
# 	## check:   this check is now done in find_mesh_index()
223
# 	# if ( data[["primitivetype"]] == "quad" & is.null( data[["ib"]] ) ) {
224
# 	# 	stop("mapdeck - badly formed mesh3d type. Found quad and expecting ib index")
225
# 	# }
226
# 	# if ( data[["primitivetype"]] == "triangle" & is.null( data[["it"]] ) ) {
227
# 	# 	stop("mapdeck - badly formed mesh3d type. Found triangle and expecting it index")
228
# 	# }
229
# 	l <- resolve_palette( l, palette )
230
# 	l <- resolve_legend( l, legend )
231
# 	l <- resolve_legend_options( l, legend_options )
232
#
233
# 	l <- resolve_data( data, l, c("POLYGON") )
234
#
235
# 	bbox <- init_bbox()
236
# 	update_view <- force( update_view )
237
# 	focus_layer <- force( focus_layer )
238
#
239
# 	is_extruded <- TRUE
240
# 	# if( !is.null( l[["stroke_width"]] ) | !is.null( l[["stroke_colour"]] ) ) {
241
# 	# 	is_extruded <- FALSE
242
# 	# 	if( !is.null( elevation ) ) {
243
# 	# 		message("stroke provided, ignoring elevation")
244
# 	# 	}
245
# 	# 	if( is.null( l[["stroke_width"]] ) ) {
246
# 	# 		l[["stroke_width"]] <- 1L
247
# 	# 	}
248
# 	# }
249
#
250
# 	if ( !is.null(l[["data"]]) ) {
251
# 		data <- l[["data"]]
252
# 		l[["data"]] <- NULL
253
# 	}
254
#
255
# 	## sf objects come with a bounding box
256
# 	if( !is.null(l[["bbox"]] ) ) {
257
# 		bbox <- l[["bbox"]]
258
# 		l[["bbox"]] <- NULL
259
# 	}
260
#
261
# 	checkHexAlpha(highlight_colour)
262
# 	layer_id <- layerId(layer_id, "mesh")
263
#
264
# 	map <- addDependency(map, mapdeckMeshDependency())
265
#
266
# 	tp <- l[["data_type"]]
267
# 	l[["data_type"]] <- NULL
268
#
269
# 	jsfunc <- "add_mesh"
270
#
271
# 	if ( tp == "mesh" ) {
272
# 		# geometry_column <- c( "geometry" )
273
# 		geometry_column <- c( vertex, index )
274
# 		shape <- rcpp_mesh_geojson2( data, geometry_column )
275
# 		# return( shape )
276
# 		# shape[["legend"]] <- list()
277
# 	}
278
#
279
# 	#	geometry_column <- c( "geometry" ) ## This is where we woudl also specify 'origin' or 'destination'
280
# 	#	shape <- rcpp_polygon_geojson( data, l, geometry_column )
281
# 	# } else if ( tp == "sfencoded" ) {
282
# 	# 	geometry_column <- "polyline"
283
# 	# 	shape <- rcpp_polygon_polyline( data, l, geometry_column )
284
# 	# 	jsfunc <- "add_polygon_polyline"
285
# 	# }
286
#
287
# 	# return( shape )
288
#
289
# 	light_settings <- jsonify::to_json(light_settings, unbox = T)
290
# 	js_transitions <- resolve_transitions( transitions, "polygon" )
291
#
292
# 	if( inherits( legend, "json" ) ) {
293
# 		shape[["legend"]] <- legend
294
# 	} else {
295
# 		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
296
# 	}
297
#
298
# 	invoke_method(
299
# 		map, jsfunc, map_type( map ), shape[["data"]], layer_id, light_settings,
300
# 		auto_highlight, highlight_colour, shape[["legend"]], bbox, update_view, focus_layer,
301
# 		js_transitions, is_extruded
302
# 	)
303
# }
304

305

306

307

308
#' @rdname clear
309
#' @export
310
clear_mesh <- function( map, layer_id = NULL) {
311 0
	layer_id <- layerId(layer_id, "mesh")
312 0
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "mesh" )
313
}
314

315

Read our documentation on viewing source code .

Loading