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

13

14

15
#' Add line
16
#'
17
#' The Line Layer renders raised lines joining pairs of source and target coordinates
18
#'
19
#' @inheritParams add_arc
20
#' @param stroke_opacity Either a string specifying the column of \code{data}
21
#' containing the opacity of each shape, or a single value in [0,255], or [0, 1),
22
#' to be applied to all the shapes. Default 255. If a hex-string is used as the
23
#' colour, this argument is ignored and you should include the alpha on the hex string
24
#' @param stroke_colour variable or hex colour to use as the ending stroke colour.
25
#' @param stroke_width width of the line in metres
26
#' @inheritSection add_arc legend
27
#' @inheritSection add_arc id
28
#'
29
#' @section transitions:
30
#'
31
#' The transitions argument lets you specify the time it will take for the shapes to transition
32
#' from one state to the next. Only works in an interactive environment (Shiny)
33
#' and on WebGL-2 supported browsers and hardware.
34
#'
35
#' The time is in milliseconds
36
#'
37
#' Available transitions for line
38
#'
39
#' list(
40
#' origin = 0,
41
#' destination = 0,
42
#' stroke_colour = 0,
43
#' stroke_width = 0
44
#' )
45
#'
46
#' @examples
47
#' \donttest{
48
#'
49
#' ## You need a valid access token from Mapbox
50
#' key <- 'abc'
51
#' set_token( key )
52
#'
53
#' url <- 'https://raw.githubusercontent.com/plotly/datasets/master/2011_february_aa_flight_paths.csv'
54
#' flights <- read.csv(url)
55
#' flights$id <- seq_len(nrow(flights))
56
#' flights$stroke <- sample(1:3, size = nrow(flights), replace = T)
57
#'
58
#' mapdeck(style = mapdeck_style("dark"), pitch = 45 ) %>%
59
#'   add_line(
60
#'     data = flights
61
#'     , layer_id = "line_layer"
62
#'     , origin = c("start_lon", "start_lat")
63
#'     , destination = c("end_lon", "end_lat")
64
#'     , stroke_colour = "airport1"
65
#'     , stroke_width = "stroke"
66
#'     , auto_highlight = TRUE
67
#'  )
68
#'
69
#' ## Using a 2-sfc-column sf object
70
#' library(sfheaders)
71
#'
72
#' sf_flights <- sfheaders::sf_point( flights, x = "start_lon", y = "start_lat", keep = TRUE )
73
#' destination <- sfheaders::sfc_point( flights, x = "end_lon", y = "end_lat" )
74
#'
75
#' sf_flights$destination <- destination
76
#'
77
#' mapdeck() %>%
78
#'  add_line(
79
#'    data = sf_flights
80
#'    , origin = 'geometry'
81
#'    , destination = 'destination'
82
#'    , layer_id = 'arcs'
83
#'    , stroke_colour = "airport1"
84
#' )
85
#' }
86
#'
87
#' @details
88
#'
89
#' \code{add_line} supports POINT sf objects
90
#'
91
#'
92
#' MULTIPOINT objects will be treated as single points. That is, if an sf object
93
#' has one row with a MULTIPOINT object consisting of two points, this will
94
#' be expanded to two rows of single POINTs.
95
#' Therefore, if the origin is a MULTIPOINT of two points, and the destination is
96
#' a single POINT, the code will error as there will be an uneven number of rows
97
#'
98
#' @export
99
add_line <- function(
100
	map,
101
	data = get_map_data(map),
102
	layer_id = NULL,
103
	origin,
104
	destination,
105
	id = NULL,
106
	stroke_colour = NULL,
107
	stroke_width = NULL,
108
	stroke_opacity = NULL,
109
	tooltip = NULL,
110
	auto_highlight = FALSE,
111
	highlight_colour = "#AAFFFFFF",
112
	palette = "viridis",
113
	na_colour = "#808080FF",
114
	legend = FALSE,
115
	legend_options = NULL,
116
	legend_format = NULL,
117
	update_view = TRUE,
118
	focus_layer = FALSE,
119
	digits = 6,
120
	transitions = NULL,
121
	brush_radius = NULL
122
) {
123

124 1
	l <- list()
125 1
	l[["origin"]] <- force( origin )
126 1
	l[["destination"]] <- force( destination)
127 1
	l[["stroke_colour"]] <- force( stroke_colour )
128 1
	l[["stroke_width"]] <- force( stroke_width )
129 1
	l[["stroke_opacity"]] <- resolve_opacity( stroke_opacity )
130 1
	l[["tooltip"]] <- force( tooltip )
131 1
	l[["id"]] <- force( id )
132 1
	l[["na_colour"]] <- force(na_colour)
133

134 1
	l <- resolve_palette( l, palette )
135 1
	l <- resolve_legend( l, legend )
136 1
	l <- resolve_legend_options( l, legend_options )
137 1
	l <- resolve_od_data( data, l, origin, destination )
138

139 1
	bbox <- init_bbox()
140 1
	update_view <- force( update_view )
141 1
	focus_layer <- force( focus_layer )
142

143 1
	if ( !is.null(l[["data"]]) ) {
144 0
		data <- l[["data"]]
145 0
		l[["data"]] <- NULL
146
	}
147

148 1
	if( !is.null(l[["bbox"]] ) ) {
149 1
		bbox <- l[["bbox"]]
150 1
		l[["bbox"]] <- NULL
151
	}
152

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

156 1
	layer_id <- layerId(layer_id, "line")
157 1
	checkHexAlpha(highlight_colour)
158

159 1
	map <- addDependency(map, mapdeckLineDependency())
160

161 1
	if ( tp == "sf" ) {
162 0
		geometry_column <- c( "origin", "destination" )
163 0
		shape <- rcpp_od_geojson( data, l, geometry_column, digits, "line" )
164 1
	} else if ( tp == "df" ) {
165 1
		geometry_column <- list( origin = c("start_lon", "start_lat","start_elev"), destination = c("end_lon", "end_lat","end_elev") )
166 1
		shape <- rcpp_od_geojson_df( data, l, geometry_column, digits, "line" )
167
	}
168
	# } else if ( tp == "sfencoded" ) {
169
	# 	geometry_column <- "geometry"
170
	# 	shape <- rcpp_od_polyline( data, l, geometry_column )
171
	# }
172

173 1
	js_transitions <- resolve_transitions( transitions, "line" )
174 1
	if( inherits( legend, "json" ) ) {
175 0
		shape[["legend"]] <- legend
176
	} else {
177 1
		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
178
	}
179

180 1
	invoke_method(
181 1
		map, "add_line_geo", map_type( map ), shape[["data"]], layer_id, auto_highlight,
182 1
		highlight_colour, shape[["legend"]], bbox, update_view, focus_layer,
183 1
		js_transitions, brush_radius
184
		)
185
}
186

187

188

189
#' @rdname clear
190
#' @export
191
clear_line <- function( map, layer_id = NULL) {
192 1
	layer_id <- layerId(layer_id, "line")
193 1
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "line" )
194
}
195

Read our documentation on viewing source code .

Loading