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

13

14
#' Add Pointcloud
15
#'
16
#' The Pointcloud Layer takes in coordinate points and renders them as circles
17
#' with a certain radius.
18
#'
19
#' @inheritParams add_scatterplot
20
#' @param elevation column containing the elevation values. Default 0
21
#' @param radius value in pixels of each point. Default 10.
22
#' @param light_settings list of light setting parameters. See \link{light_settings}
23
#'
24
#' @inheritSection add_polygon data
25
#' @inheritSection add_arc legend
26
#' @inheritSection add_arc id
27
#'
28
#' @section transitions:
29
#'
30
#' The transitions argument lets you specify the time it will take for the shapes to transition
31
#' from one state to the next. Only works in an interactive environment (Shiny)
32
#' and on WebGL-2 supported browsers and hardware.
33
#'
34
#' The time is in milliseconds
35
#'
36
#' Available transitions for pointcloud
37
#'
38
#' list(
39
#' position = 0,
40
#' fill_colour = 0
41
#' )
42
#'
43
#' @examples
44
#' \donttest{
45
#' ## You need a valid access token from Mapbox
46
#' key <- 'abc'
47
#' set_token( key )
48
#'
49
#' df <- capitals
50
#' df$z <- sample(10000:10000000, size = nrow(df))
51
#'
52
#' mapdeck(style = mapdeck_style("dark")) %>%
53
#' add_pointcloud(
54
#'   data = df
55
#'   , lon = 'lon'
56
#'   , lat = 'lat'
57
#'   , elevation = 'z'
58
#'   , layer_id = 'point'
59
#'   , fill_colour = "country"
60
#'   , tooltip = "country"
61
#' )
62
#'
63
#' ## as an sf object wtih a Z attribute
64
#' library(sfheaders)
65
#' sf <- sfheaders::sf_point( df, x = "lon", y = "lat", z = "z" )
66
#'
67
#' mapdeck(style = mapdeck_style("dark")) %>%
68
#' add_pointcloud(
69
#'   data = sf
70
#'   , layer_id = 'point'
71
#'   , fill_colour = "country"
72
#'   , tooltip = "country"
73
#'   , update_view = FALSE
74
#' )
75
#'
76
#' }
77
#'
78
#' @details
79
#'
80
#' \code{add_pointcloud} supports POINT and MULTIPOINT sf objects
81
#'
82
#' @export
83
add_pointcloud <- function(
84
	map,
85
	data = get_map_data(map),
86
	lon = NULL,
87
	lat = NULL,
88
	elevation = NULL,
89
	polyline = NULL,
90
	radius = 10,
91
	fill_colour = NULL,
92
	fill_opacity = NULL,
93
	tooltip = NULL,
94
	auto_highlight = FALSE,
95
	highlight_colour = "#AAFFFFFF",
96
	light_settings = list(),
97
	layer_id = NULL,
98
	id = NULL,
99
	palette = "viridis",
100
	na_colour = "#808080FF",
101
	legend = FALSE,
102
	legend_options = NULL,
103
	legend_format = NULL,
104
	update_view = TRUE,
105
	focus_layer = FALSE,
106
	digits = 6,
107
	transitions = NULL,
108
	brush_radius = NULL
109
) {
110

111
	## using binary data requires hex-colorus to include teh alpha
112 1
	if( !is.null( fill_colour ) ) {
113 0
	  fill_colour <- appendAlpha( fill_colour )
114
	}
115

116 1
	l <- list()
117 1
	l[["lon"]] <- force( lon )
118 1
	l[["lat"]] <- force( lat )
119 1
	l[["polyline"]] <- force( polyline )
120 1
	l[["elevation"]] <- force( elevation )
121 1
	l[["fill_colour"]] <- force( fill_colour )
122 1
	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
123 1
	l[["tooltip"]] <- force( tooltip )
124 1
	l[["id"]] <- force( id )
125 1
	l[["na_colour"]] <- force( na_colour )
126

127 1
	l <- resolve_palette( l, palette )
128 1
	l <- resolve_legend( l, legend )
129 1
	l <- resolve_legend_options( l, legend_options )
130 1
	l <- resolve_elevation_data( data, l, elevation, c("POINT") )
131

132 1
	bbox <- init_bbox()
133 1
	update_view <- force( update_view )
134 1
	focus_layer <- force( focus_layer )
135

136 1
	if ( !is.null(l[["data"]]) ) {
137 1
		data <- l[["data"]]
138 1
		l[["data"]] <- NULL
139
	}
140

141 1
	if( !is.null(l[["bbox"]] ) ) {
142 1
		bbox <- l[["bbox"]]
143 1
		l[["bbox"]] <- NULL
144
	}
145

146 1
	checkHexAlpha( highlight_colour )
147 1
	layer_id <- layerId( layer_id, "pointcloud" )
148 1
	checkNumeric( radius )
149

150 1
	map <- addDependency( map, mapdeckPointcloudDependency() )
151

152 1
	tp <- l[["data_type"]]
153 1
	l[["data_type"]] <- NULL
154 1
	jsfunc <- "add_pointcloud_geo_columnar"
155

156 1
	if ( tp == "sf" ) {
157

158 0
		geometry_column <- list( geometry = c("lon","lat","elevation") )  ## using columnar structure, the 'sf' is converted to a data.frame
159
		## so the geometry columns are obtained after sfheaders::sf_to_df()
160 0
		l[["geometry"]] <- NULL
161 0
		shape <- rcpp_point_sf_columnar( data, l, geometry_column, digits, "pointcloud" )
162

163
		# geometry_column <- c( "geometry" )
164
		# shape <- rcpp_point_geojson( data, l, geometry_column, digits, "pointcloud" )
165

166 1
	} else if ( tp == "df" ) {
167
		## TODO( here or in rcpp? )
168 1
		if( is.null( elevation ) ){
169 1
			l[["elevation"]] <- 0
170
		}
171

172
		#print( head( data )  )
173 1
		geometry_column <- list( geometry = c("lon", "lat","elevation") )
174 1
		shape <- rcpp_point_df_columnar( data, l, geometry_column, digits, "pointcloud" )
175

176
	# 	geometry_column <- list( geometry = c("lon","lat","elevation") )
177
	#   shape <- rcpp_point_geojson_df( data, l, geometry_column, digits, "pointcloud" )
178

179 1
	} else if ( tp == "sfencoded" ) {
180

181 0
		geometry_column <- "polyline"
182 0
		shape <- rcpp_point_polyline( data, l, geometry_column, "pointcloud" )
183 0
		jsfunc <- "add_pointcloud_polyline"
184
	}
185

186 1
	light_settings <- jsonify::to_json(light_settings, unbox = T)
187 1
	js_transitions <- resolve_transitions( transitions, "pointcloud" )
188

189 1
	if( inherits( legend, "json" ) ) {
190 0
		shape[["legend"]] <- legend
191 0
		legend_format <- "hex"
192
	} else {
193 1
		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
194 1
		legend_format <- "rgb"
195
	}
196

197 1
	invoke_method(
198 1
		map, jsfunc, map_type( map ), shape[["data"]], nrow(data), radius, layer_id, light_settings,
199 1
		auto_highlight, highlight_colour, shape[["legend"]], legend_format, bbox, update_view, focus_layer,
200 1
		js_transitions, brush_radius
201
		)
202
}
203

204

205
#' @rdname clear
206
#' @export
207
clear_pointcloud <- function( map, layer_id = NULL) {
208 1
	layer_id <- layerId( layer_id, "pointcloud" )
209 1
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "pointcloud" )
210
}
211

Read our documentation on viewing source code .

Loading