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

13

14
#' Add Grid
15
#'
16
#' The Grid Layer renders a grid heatmap based on an array of points.
17
#' It takes the constant size all each cell, projects points into cells.
18
#' The color and height of the cell is scaled by number of points it contains.
19
#'
20
#' @inheritParams add_polygon
21
#' @inheritParams add_hexagon
22
#' @param lon column containing longitude values
23
#' @param lat column containing latitude values
24
#' @param colour_range vector of 6 hex colours
25
#' @param cell_size size of each cell in meters. Default 1000
26
#' @param extruded logical indicating if cells are elevated or not. Default TRUE
27
#'
28
#' @inheritSection add_polygon data
29
#'
30
#' @examples
31
#' \donttest{
32
#' ## You need a valid access token from Mapbox
33
#' key <- 'abc'
34
#' set_token( key )
35
#'
36
#' df <- read.csv(paste0(
37
#' 'https://raw.githubusercontent.com/uber-common/deck.gl-data/master/',
38
#' 'examples/3d-heatmap/heatmap-data.csv'
39
#' ))
40
#'
41
#' df <- df[ !is.na(df$lng ), ]
42
#'
43
#' mapdeck( style = mapdeck_style("dark"), pitch = 45 ) %>%
44
#' add_grid(
45
#'   data = df
46
#'   , lat = "lat"
47
#'   , lon = "lng"
48
#'   , cell_size = 5000
49
#'   , elevation_scale = 50
50
#'   , layer_id = "grid_layer"
51
#'   , auto_highlight = TRUE
52
#' )
53
#'
54
#' ## using sf object
55
#' library(sfheaders)
56
#' sf <- sfheaders::sf_point( df, x = "lng", y = "lat")
57
#'
58
#' mapdeck( style = mapdeck_style("dark"), pitch = 45 ) %>%
59
#' add_grid(
60
#'   data = sf
61
#'   , cell_size = 5000
62
#'   , elevation_scale = 50
63
#'   , layer_id = "grid_layer"
64
#'   , auto_highlight = TRUE
65
#' )
66
#'
67
#' ## using colour and elevation functions, and legends
68
#' df$val <- sample(1:10, size = nrow(df), replace = T)
69
#'
70
#' mapdeck( style = mapdeck_style("dark"), pitch = 45) %>%
71
#' add_grid(
72
#' 	data = df
73
#' 	, lat = "lat"
74
#' 	, lon = "lng"
75
#' 	, layer_id = "hex_layer"
76
#' 	, elevation_scale = 100
77
#' 	, legend = T
78
#' 	, colour_function = "max"
79
#' 	, colour = "val"
80
#' )
81
#'
82
#' mapdeck( style = mapdeck_style("dark"), pitch = 45) %>%
83
#' add_grid(
84
#' 	data = df
85
#' 	, lat = "lat"
86
#' 	, lon = "lng"
87
#' 	, layer_id = "hex_layer"
88
#' 	, elevation_scale = 10
89
#' 	, legend = T
90
#' 	, elevation_function = "mean"
91
#' 	, elevation = "val"
92
#' )
93
#'
94
#' }
95
#'
96
#' @details
97
#'
98
#' \code{add_grid} supports POINT and MULTIPOINT sf objects
99
#'
100
#' @seealso add_hexagon
101
#'
102
#' @export
103
add_grid <- function(
104
	map,
105
	data = get_map_data(map),
106
	lon = NULL,
107
	lat = NULL,
108
	polyline = NULL,
109
	cell_size = 1000,
110
	extruded = TRUE,
111
	elevation = NULL,
112
	elevation_function =  c("sum","mean","min","max"),
113
	colour = NULL,
114
	colour_function =  c("sum","mean","min","max"),
115
	elevation_scale = 1,
116
	colour_range = NULL,
117
	legend = FALSE,
118
	legend_options = NULL,
119
	auto_highlight = FALSE,
120
	highlight_colour = "#AAFFFFFF",
121
	layer_id = NULL,
122
	update_view = TRUE,
123
	focus_layer = FALSE,
124
	digits = 6,
125
	transitions = NULL,
126
	brush_radius = NULL
127
) {
128

129 1
	l <- list()
130 1
	l[["lon"]] <- force( lon )
131 1
	l[["lat"]] <- force( lat )
132 1
	l[["polyline"]] <- force( polyline )
133 1
	l[["elevation"]] <- force( elevation )
134 1
	l[["colour"]] <- force( colour )
135

136 1
	colour_function <- match.arg( colour_function )
137 1
	colour_function <- toupper( colour_function )
138

139 1
	elevation_function <- match.arg( elevation_function )
140 1
	elevation_function <- toupper( elevation_function )
141

142 1
	legend <- force( legend )
143 1
	legend <- aggregation_legend( legend, legend_options )
144

145 1
	use_weight <- FALSE
146 1
	if(!is.null(elevation)) use_weight <- TRUE
147

148 1
	use_colour <- FALSE
149 1
	if(!is.null(colour)) use_colour <- TRUE
150

151 1
	l <- resolve_data( data, l, c("POINT") )
152

153 1
	bbox <- init_bbox()
154 1
	update_view <- force( update_view )
155 1
	focus_layer <- force( focus_layer )
156

157 1
	if ( !is.null(l[["data"]]) ) {
158 1
		data <- l[["data"]]
159 1
		l[["data"]] <- NULL
160
	}
161

162 1
	if( !is.null(l[["bbox"]] ) ) {
163 1
		bbox <- l[["bbox"]]
164 1
		l[["bbox"]] <- NULL
165
	}
166

167
	## parmater checks
168 1
	checkNumeric(elevation_scale)
169 1
	checkNumeric(cell_size)
170

171 1
	if( is.null( colour_range ) ) {
172 1
		colour_range <- colourvalues::colour_values(1:6, palette = "viridis")
173
	}
174

175 1
	if(length(colour_range) != 6)
176 1
		stop("mapdeck - colour_range must have 6 hex colours")
177

178 1
	checkHex(colour_range)
179

180 1
	checkHexAlpha(highlight_colour)
181 1
	layer_id <- layerId(layer_id, "grid")
182

183 1
	map <- addDependency(map, mapdeckGridDependency())
184

185 1
	tp <- l[["data_type"]]
186 1
	l[["data_type"]] <- NULL
187

188 1
	jsfunc <- "add_grid_geo"
189

190 1
	if ( tp == "sf" ) {
191

192
		# geometry_column <- list( geometry = c("lon","lat") )  ## using columnar structure, the 'sf' is converted to a data.frame
193
		## so the geometry columns are obtained after sfheaders::sf_to_df()
194
		# l[["geometry"]] <- NULL
195
		# shape <- rcpp_point_sf_columnar( data, l, geometry_column, digits, "grid" )
196

197 0
	  geometry_column <- c( "geometry" )
198 0
	  shape <- rcpp_aggregate_geojson( data, l, geometry_column, digits, "grid" )
199 1
	} else if ( tp == "df" ) {
200

201
		# geometry_column <- list( geometry = c("lon", "lat") )
202
		# shape <- rcpp_point_df_columnar( data, l, geometry_column, digits, "grid" )
203

204 1
		geometry_column <- list( geometry = c("lon", "lat") )
205 1
		shape <- rcpp_aggregate_geojson_df( data, l, geometry_column, digits, "grid" )
206 1
	} else if ( tp == "sfencoded" ) {
207 0
		geometry_column <- "polyline"
208 0
		shape <- rcpp_aggregate_polyline( data, l, geometry_column, "grid" )
209 0
		jsfunc <- "add_grid_polyline"
210
	}
211

212 1
	js_transitions <- resolve_transitions( transitions, "grid" )
213

214 1
	invoke_method(
215 1
		map, jsfunc, map_type( map ), shape[["data"]], layer_id, cell_size,
216 1
		jsonify::to_json(extruded, unbox = TRUE), elevation_scale,
217 1
		colour_range, auto_highlight, highlight_colour, bbox, update_view, focus_layer,
218 1
		js_transitions, use_weight, use_colour, elevation_function, colour_function, legend,
219 1
		brush_radius
220
		)
221
}
222

223

224
#' @rdname clear
225
#' @export
226
clear_grid <- function( map, layer_id = NULL) {
227 1
	layer_id <- layerId(layer_id, "grid")
228 1
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "grid" )
229
}

Read our documentation on viewing source code .

Loading