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

13

14
#' Add Screengrid
15
#'
16
#' The Screen Grid Layer takes in an array of latitude and longitude coordinated points,
17
#' aggregates them into histogram bins and renders as a grid
18
#'
19
#' @inheritParams add_polygon
20
#' @param lon column containing longitude values
21
#' @param lat column containing latitude values
22
#' @param weight the weight of each value. Default 1
23
#' @param aggregation one of 'min', 'mean', 'max', 'sum'.
24
#' If supplied it specifies how the weights used.
25
#' @param colour_range vector of 6 hex colours
26
#' @param opacity opacity of cells. Value between 0 and 1. Default 0.8
27
#' @param cell_size size of grid squares in pixels. Default 50
28
#'
29
#' @inheritSection add_polygon data
30
#'
31
#' @examples
32
#' \donttest{
33
#'
34
#' ## You need a valid access token from Mapbox
35
#' key <- 'abc'
36
#' set_token( key )
37
#'
38
#' df <- read.csv(paste0(
39
#' 'https://raw.githubusercontent.com/uber-common/deck.gl-data/master/',
40
#' 'examples/3d-heatmap/heatmap-data.csv'
41
#' ))
42
#'
43
#' df <- df[ !is.na(df$lng), ]
44
#' df$weight <- sample(1:10, size = nrow(df), replace = T)
45
#'
46
#' mapdeck( style = mapdeck_style('dark'), pitch = 45 ) %>%
47
#' add_screengrid(
48
#'   data = df
49
#'   , lat = "lat"
50
#'   , lon = "lng"
51
#'   , weight = "weight",
52
#'   , layer_id = "screengrid_layer"
53
#'   , cell_size = 10
54
#'   , opacity = 0.3
55
#' )
56
#'
57
#' ## as an sf object
58
#' library(sfheaders)
59
#' sf <- sfheaders::sf_point( df, x = "lng", y = "lat")
60
#'
61
#' mapdeck( style = mapdeck_style('dark'), pitch = 45 ) %>%
62
#' add_screengrid(
63
#'   data = sf
64
#'   , weight = "weight",
65
#'   , layer_id = "screengrid_layer"
66
#'   , cell_size = 10
67
#'   , opacity = 0.3
68
#' )
69
#'
70
#' }
71
#'
72
#' @details
73
#'
74
#' \code{add_screengrid} supports POINT and MULTIPOINT sf objects
75
#'
76
#' @export
77
add_screengrid <- function(
78
	map,
79
	data = get_map_data(map),
80
	lon = NULL,
81
	lat = NULL,
82
	polyline = NULL,
83
	weight = NULL,
84
	aggregation = c("sum","mean","min","max"),
85
	colour_range = NULL,
86
	opacity = 0.8,
87
	cell_size = 50,
88
	layer_id = NULL,
89
	update_view = TRUE,
90
	focus_layer = FALSE,
91
	digits = 6
92
) {
93 1
	brush_radius = NULL
94 1
	l <- list()
95 1
	l[["polyline"]] <- force( polyline )
96 1
	l[["weight"]] <- force( weight )
97 1
	l[["lon"]] <- force( lon )
98 1
	l[["lat"]] <- force( lat )
99

100 1
	l <- resolve_data( data, l, c("POINT") )
101

102 1
	aggregation <- match.arg( aggregation )
103 1
	aggregation <- toupper( aggregation )
104

105 1
	bbox <- init_bbox()
106 1
	update_view <- force( update_view )
107 1
	focus_layer <- force( focus_layer )
108

109 1
	if ( !is.null(l[["data"]]) ) {
110 1
		data <- l[["data"]]
111 1
		l[["data"]] <- NULL
112
	}
113

114 1
	if( !is.null(l[["bbox"]] ) ) {
115 1
		bbox <- l[["bbox"]]
116 1
		l[["bbox"]] <- NULL
117
	}
118

119
	## parmater checks
120
	#usePolyline <- isUsingPolyline(polyline)
121 1
	checkNumeric(opacity)
122 1
	checkNumeric(cell_size)
123 1
	layer_id <- layerId(layer_id, "screengrid")
124

125 1
	if( is.null( colour_range ) ) {
126 1
		colour_range <- colourvalues::colour_values(1:6, palette = "viridis")
127
	}
128

129 1
	if(length(colour_range) != 6)
130 1
		stop("mapdeck - colour_range must have 6 hex colours")
131
	## end parameter checks
132

133 1
	checkHex(colour_range)
134

135 1
	map <- addDependency(map, mapdeckScreengridDependency())
136

137 1
	tp <- l[["data_type"]]
138 1
	l[["data_type"]] <- NULL
139

140 1
	jsfunc <- "add_screengrid_geo"
141 1
	if( tp == "sf" ) {
142 0
		geometry_column <- c( "geometry" )
143 0
		shape <- rcpp_aggregate_geojson( data, l, geometry_column, digits, "screengrid" )
144 1
	} else if ( tp == "df" ) {
145 1
		geometry_column <- list( geometry = c("lon", "lat") )
146 1
		shape <- rcpp_aggregate_geojson_df( data, l, geometry_column, digits, "screengrid" )
147 1
	} else if ( tp == "sfencoded" ) {
148 0
		geometry_column <- "polyline"
149 0
		shape <- rcpp_aggregate_polyline( data, l, geometry_column, "screengrid" )
150 0
		jsfunc <- "add_screengrid_polyline"
151
	}
152

153 1
	invoke_method(
154 1
		map, jsfunc, map_type( map ), shape[["data"]], layer_id, opacity, cell_size, colour_range,
155 1
		bbox, update_view, focus_layer, aggregation, brush_radius
156
		)
157
}
158

159

160
#' @rdname clear
161
#' @export
162
clear_screengrid <- function( map, layer_id = NULL) {
163 1
	layer_id <- layerId(layer_id, "screengrid")
164 1
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "screengrid" )
165
}
166

Read our documentation on viewing source code .

Loading