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

13

14
#' Add column
15
#'
16
#'The ColumnLayer can be used to render a heatmap of vertical cylinders. It renders
17
#'a tesselated regular polygon centered at each given position (a "disk"), and extrude it in 3d.
18
#'
19
#' @inheritParams add_polygon
20
#' @param lon column containing longitude values
21
#' @param lat column containing latitude values
22
#' @param polyline column of \code{data} containing the polylines
23
#' @param disk_resolution The number of sides to render the disk as.
24
#' The disk is a regular polygon that fits inside the given radius.
25
#' A higher resolution will yield a smoother look close-up, but also requires more resources to render.
26
#' @param radius in metres. Default 1000
27
#' @param angle disk rotation, counter-clockwise, in degrees
28
#' @param coverage radius multiplier, in range [0,1]. The radius of the disk is calcualted
29
#' by coverage * radius
30
#' @param elevation_scale value to scale the elevations of the columns Default 1
31
#'
32
#' @inheritSection add_polygon data
33
#' @inheritSection add_arc legend
34
#' @inheritSection add_arc id
35
#'
36
#' @examples
37
#' \dontrun{
38
#'
39
#' ## You need a valid access token from Mapbox
40
#' key <- 'abc'
41
#' set_token( key )
42
#'
43
#'
44
#' df <- capitals
45
#' df$elev <- sample(50000:500000, size = nrow(df), replace = T)
46
#'
47
#' mapdeck(style = mapdeck_style("dark"), pitch = 45) %>%
48
#' add_column(
49
#'   data = df
50
#'   , lat = "lat"
51
#'   , lon = "lon"
52
#'   , elevation = "elev"
53
#'   , fill_colour = "lon"
54
#'   , disk_resolution = 20
55
#'   , radius = 100000
56
#'   , tooltip = "capital"
57
#' )
58
#'
59
#' library(sfheaders)
60
#' sf <- sfheaders::sf_point( df, x = "lon", y = "lat" )
61
#'
62
#' sf$elev <- df$elev
63
#'
64
#' mapdeck( style = mapdeck_style("dark"), pitch = 45 ) %>%
65
#' add_column(
66
#'   data = sf
67
#'   , layer_id = "col_layer"
68
#'   , elevation = "elev"
69
#'   , radius = 100000
70
#'   , fill_colour = "country"
71
#' )
72
#'
73
#'
74
#' }
75
#'
76
#' @details
77
#'
78
#' \code{add_column} supports POINT and MULTIPOINT sf objects
79
#'
80
#'
81
#' @export
82
add_column <- function(
83
	map,
84
	data = get_map_data(map),
85
	polyline = NULL,
86
	lon = NULL,
87
	lat = NULL,
88
	fill_colour = NULL,
89
	fill_opacity = NULL,
90
	stroke_colour = NULL,
91
	stroke_opacity = NULL,
92
	stroke_width = NULL,
93
	radius = 1000,
94
	elevation = NULL,
95
	elevation_scale = 1,
96
	coverage = 1,
97
	angle = 0,
98
	disk_resolution = 20,
99
	tooltip = NULL,
100
	auto_highlight = FALSE,
101
	highlight_colour = "#AAFFFFFF",
102
	layer_id = NULL,
103
	id = NULL,
104
	palette = "viridis",
105
	na_colour = "#808080FF",
106
	legend = FALSE,
107
	legend_options = NULL,
108
	legend_format = NULL,
109
	update_view = TRUE,
110
	focus_layer = FALSE,
111
	digits = 6,
112
	transitions = NULL,
113
	brush_radius = NULL
114
) {
115

116
	## using binary data requires hex-colorus to include teh alpha
117 0
	if( !is.null( fill_colour ) ) {
118 0
		fill_colour <- appendAlpha( fill_colour )
119
	}
120 0
	if( !is.null( stroke_colour ) ) {
121 0
		stroke_colour <- appendAlpha( stroke_colour )
122
	}
123

124 0
	l <- list()
125 0
	l[["polyline"]] <- force( polyline )
126 0
	l[["lon"]] <- force( lon )
127 0
	l[["lat"]] <- force( lat )
128 0
	l[["fill_colour"]] <- fill_colour
129 0
	l[["fill_opacity"]] <- resolve_opacity( fill_opacity )
130 0
	l[["stroke_colour"]] <-force( stroke_colour )
131 0
	l[["stroke_width"]] <- force( stroke_width )
132 0
	l[["stroke_opacity"]] <- resolve_opacity( stroke_opacity )
133 0
	l[["elevation"]] <- force( elevation )
134 0
	l[["tooltip"]] <- force( tooltip )
135 0
	l[["id"]] <- force( id )
136 0
	l[["na_colour"]] <- force( na_colour )
137

138

139 0
	l <- resolve_palette( l, palette )
140 0
	l <- resolve_legend( l, legend )
141 0
	l <- resolve_legend_options( l, legend_options )
142 0
	l <- resolve_elevation_data( data, l, elevation, c("POINT") )
143

144 0
	bbox <- init_bbox()
145 0
	update_view <- force( update_view )
146 0
	focus_layer <- force( focus_layer )
147

148 0
	is_extruded <- FALSE
149
	## issue 287 & 296
150 0
	if( !is.null( elevation ) ) {
151 0
		is_extruded <- TRUE
152
	}
153 0
	if( !is.null( l[["stroke_width"]] ) | !is.null( l[["stroke_colour"]] ) ) {
154 0
		is_extruded <- FALSE
155 0
		if( !is.null( elevation ) ) {
156 0
			message("stroke provided, ignoring elevation")
157
		}
158 0
		if( is.null( l[["stroke_width"]] ) ) {
159 0
			l[["stroke_width"]] <- 1L
160
		}
161
	}
162

163 0
	if ( !is.null(l[["data"]]) ) {
164 0
		data <- l[["data"]]
165 0
		l[["data"]] <- NULL
166
	}
167

168 0
	if( !is.null(l[["bbox"]] ) ) {
169 0
		bbox <- l[["bbox"]]
170 0
		l[["bbox"]] <- NULL
171
	}
172

173 0
	checkHexAlpha(highlight_colour)
174

175 0
	layer_id <- layerId(layer_id, "column")
176 0
	map <- addDependency(map, mapdeckColumnDependency())
177

178 0
	tp <- l[["data_type"]]
179 0
	l[["data_type"]] <- NULL
180 0
	jsfunc <- "add_column_geo_columnar"
181

182

183 0
	if ( tp == "sf" ) {
184

185 0
		geometry_column <- list( geometry = c("lon","lat") )  ## using columnar structure, the 'sf' is converted to a data.frame
186
		## so the geometry columns are obtained after sfheaders::sf_to_df()
187 0
		l[["geometry"]] <- NULL
188 0
		shape <- rcpp_point_sf_columnar( data, l, geometry_column, digits, "column" )
189

190
		# geometry_column <- c( "geometry" )
191
		# shape <- rcpp_point_geojson( data, l, geometry_column, digits, "column" )
192

193 0
	} else if ( tp == "df" ) {
194

195 0
		geometry_column <- list( geometry = c("lon", "lat") )
196 0
		shape <- rcpp_point_df_columnar( data, l, geometry_column, digits, "column" )
197

198
		# geometry_column <- list( geometry = c("lon", "lat") )
199
		# shape <- rcpp_point_geojson_df( data, l, geometry_column, digits, "column" )
200

201 0
	} else if ( tp == "sfencoded" ) {
202 0
		geometry_column <- "polyline"
203 0
		shape <- rcpp_point_polyline( data, l, geometry_column, "column" )
204 0
		jsfunc <- "add_column_polyline"
205

206
	}
207

208 0
	js_transitions <- resolve_transitions( transitions, "column" )
209

210 0
	if( inherits( legend, "json" ) ) {
211 0
		shape[["legend"]] <- legend
212 0
		legend_format <- "hex"
213
	} else {
214 0
		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
215 0
		legend_format <- "rgb"
216
	}
217

218 0
	invoke_method(
219 0
		map, jsfunc, map_type( map ), shape[["data"]], nrow(data), layer_id, auto_highlight, highlight_colour,
220 0
		radius, elevation_scale, disk_resolution, angle, coverage, shape[["legend"]], legend_format,
221 0
		bbox, update_view, focus_layer, js_transitions, is_extruded, brush_radius
222
	)
223
}
224

225

226
#' @rdname clear
227
#' @export
228
clear_column <- function( map, layer_id = NULL) {
229 0
	layer_id <- layerId(layer_id, "column")
230 0
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "column" )
231
}

Read our documentation on viewing source code .

Loading