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

13
#' Add Heatmap
14
#'
15
#' The Heatmap Layer can be used to visualise spatial distribution of data.
16
#' It implements Gaussian Kernel Density Estimation to render the heatmaps.
17
#'
18
#' @section note:
19
#'
20
#' The current version of this layer is supported only for WebGL2 enabled browswers
21
#' So you may find it doesn't render in the RStudio viewer.
22
#'
23
#' @inheritParams add_polygon
24
#' @param lon column containing longitude values
25
#' @param lat column containing latitude values
26
#' @param weight the weight of each value. Default 1
27
#' @param colour_range vector of 6 hex colours
28
#' @param radius_pixels Radius of the circle in pixels, to which the weight of an object is distributed
29
#' @param intensity Value that is multiplied with the total weight at a pixel to
30
#' obtain the final weight. A value larger than 1 biases the output color towards
31
#' the higher end of the spectrum, and a value less than 1 biases the output
32
#' color towards the lower end of the spectrum
33
#' @param threshold The HeatmapLayer reduces the opacity of the pixels with relatively
34
#' low weight to create a fading effect at the edge.
35
#' A larger threshold smoothens the boundaries of color blobs, while making pixels
36
#' with low relative weight harder to spot (due to low alpha value).
37
#' Threshold is defined as the ratio of the fading weight to the max weight, between 0 and 1.
38
#' For example, 0.1 affects all pixels with weight under 10\% of the max.
39
#'
40
#' @inheritSection add_polygon data
41
#'
42
#' @section transitions:
43
#'
44
#' The transitions argument lets you specify the time it will take for the shapes to transition
45
#' from one state to the next. Only works in an interactive environment (Shiny)
46
#' and on WebGL-2 supported browsers and hardware.
47
#'
48
#' The time is in milliseconds
49
#'
50
#' Available transitions for heatmap
51
#'
52
#' list(
53
#' intensity = 0,
54
#' threshold = 0,
55
#' radius_pixels = 0
56
#' )
57
#'
58
#' @examples
59
#' \donttest{
60
#'
61
#' ## You need a valid access token from Mapbox
62
#' key <- 'abc'
63
#' set_token( key )
64
#'
65
#' df <- read.csv(paste0(
66
#' 'https://raw.githubusercontent.com/uber-common/deck.gl-data/master/',
67
#' 'examples/3d-heatmap/heatmap-data.csv'
68
#' ))
69
#'
70
#' df <- df[ !is.na(df$lng), ]
71
#' df$weight <- sample(1:10, size = nrow(df), replace = T)
72
#'
73
#' mapdeck( style = mapdeck_style('dark'), pitch = 45 ) %>%
74
#' add_heatmap(
75
#'   data = df
76
#'   , lat = "lat"
77
#'   , lon = "lng"
78
#'   , weight = "weight",
79
#'   , layer_id = "heatmap_layer"
80
#' )
81
#'
82
#' ## as an sf object
83
#' library(sfheaders)
84
#' sf <- sfheaders::sf_point( df, x = "lng", y = "lat")
85
#'
86
#' mapdeck( style = mapdeck_style('dark'), pitch = 45 ) %>%
87
#' add_heatmap(
88
#'   data = sf
89
#'   , weight = "weight",
90
#'   , layer_id = "heatmap_layer"
91
#' )
92
#'
93
#' }
94
#'
95
#' @details
96
#'
97
#' \code{add_heatmap} supports POINT and MULTIPOINT sf objects
98
#'
99
#' @export
100
add_heatmap <- function(
101
	map,
102
	data = get_map_data(map),
103
	lon = NULL,
104
	lat = NULL,
105
	polyline = NULL,
106
	weight = NULL,
107
	colour_range = NULL,
108
	radius_pixels = 30,
109
	intensity = 1,
110
	threshold = 0.05,
111
	layer_id = NULL,
112
	update_view = TRUE,
113
	focus_layer = FALSE,
114
	digits = 6,
115
	transitions = NULL
116
) {
117

118
	#experimental_layer("heatmap")
119

120 0
	l <- list()
121 0
	l[["polyline"]] <- force( polyline )
122 0
	l[["weight"]] <- force( weight )
123 0
	l[["lon"]] <- force( lon )
124 0
	l[["lat"]] <- force( lat )
125

126 0
	l <- resolve_data( data, l, c("POINT") )
127

128 0
	bbox <- init_bbox()
129 0
	update_view <- force( update_view )
130 0
	focus_layer <- force( focus_layer )
131

132 0
	if ( !is.null(l[["data"]]) ) {
133 0
		data <- l[["data"]]
134 0
		l[["data"]] <- NULL
135
	}
136

137 0
	if( !is.null(l[["bbox"]] ) ) {
138 0
		bbox <- l[["bbox"]]
139 0
		l[["bbox"]] <- NULL
140
	}
141

142
	## parmater checks
143
	#usePolyline <- isUsingPolyline(polyline)
144 0
	layer_id <- layerId(layer_id, "heatmap")
145

146 0
	if( is.null( colour_range ) ) {
147 0
		colour_range <- colourvalues::colour_values(1:6, palette = "viridis")
148
	}
149

150 0
	if(length(colour_range) != 6)
151 0
		stop("mapdeck - colour_range must have 6 hex colours")
152
	## end parameter checks
153

154 0
	checkHex(colour_range)
155

156 0
	map <- addDependency(map, mapdeckHeatmapDependency())
157

158 0
	tp <- l[["data_type"]]
159 0
	l[["data_type"]] <- NULL
160

161 0
	jsfunc <- "add_heatmap_geo"
162 0
	if( tp == "sf" ) {
163 0
		geometry_column <- c( "geometry" )
164 0
		shape <- rcpp_aggregate_geojson( data, l, geometry_column, digits, "heatmap" )
165 0
	} else if ( tp == "df" ) {
166 0
		geometry_column <- list( geometry = c("lon", "lat") )
167 0
		shape <- rcpp_aggregate_geojson_df( data, l, geometry_column, digits, "heatmap" )
168 0
	} else if ( tp == "sfencoded" ) {
169 0
		geometry_column <- "polyline"
170 0
		shape <- rcpp_aggregate_polyline( data, l, geometry_column, "heatmap" )
171 0
		jsfunc <- "add_heatmap_polyline"
172
	}
173

174 0
	js_transitions <- resolve_transitions( transitions, "heatmap" )
175

176 0
	invoke_method(
177 0
		map, jsfunc, map_type( map ), shape[["data"]], layer_id, colour_range,
178 0
		radius_pixels, intensity, threshold, bbox, update_view, focus_layer, js_transitions
179
	)
180
}
181

182

183
#' @rdname clear
184
#' @export
185
clear_heatmap <- function( map, layer_id = NULL) {
186 0
	layer_id <- layerId(layer_id, "heatmap")
187 0
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "heatmap" )
188
}

Read our documentation on viewing source code .

Loading