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

13
#' Add greatcircle
14
#'
15
#' Renders flat arcs along the great circle joining pairs
16
#' of source and target points, specified as longitude/latitude coordinates.
17
#'
18
#' @inheritParams add_arc
19
#' @param wrap_longitude logical, whether to automatically wrap longitudes over the
20
#' 180th antimeridian.
21

22
#' @inheritSection add_arc legend
23
#' @inheritSection add_arc id
24
#'
25
#' @examples
26
#' \donttest{
27
#'
28
#' ## You need a valid access token from Mapbox
29
#' set_token("MAPBOX_TOKEN")
30
#'
31
#' url <- 'https://raw.githubusercontent.com/plotly/datasets/master/2011_february_aa_flight_paths.csv'
32
#' flights <- read.csv(url)
33
#' flights$id <- seq_len(nrow(flights))
34
#' flights$stroke <- sample(1:3, size = nrow(flights), replace = T)
35
#' flights$info <- paste0("<b>",flights$airport1, " - ", flights$airport2, "</b>")
36
#'
37
#' mapdeck( style = mapdeck_style("dark"), pitch = 45 ) %>%
38
#'   add_greatcircle(
39
#'   data = flights
40
#'   , layer_id = "greatcircle_layer"
41
#'   , origin = c("start_lon", "start_lat")
42
#'   , destination = c("end_lon", "end_lat")
43
#'   , stroke_from = "airport1"
44
#'   , stroke_to = "airport2"
45
#'   , stroke_width = "stroke"
46
#'   , tooltip = "info"
47
#'   , auto_highlight = TRUE
48
#'   , legend = T
49
#'   , legend_options = list(
50
#'     stroke_from = list( title = "Origin airport" ),
51
#'     css = "max-height: 100px;")
52
#'  )
53
#'
54
#' mapdeck( style = mapdeck_style("dark")) %>%
55
#'   add_greatcircle(
56
#'   data = flights
57
#'   , layer_id = "greatcircle_layer"
58
#'   , origin = c("start_lon", "start_lat")
59
#'   , destination = c("end_lon", "end_lat")
60
#'   , stroke_from = "airport1"
61
#'   , stroke_to = "airport2"
62
#'   , stroke_width = "stroke"
63
#'   )
64
#'
65
#' ## Using a 2-sfc-column sf object
66
#' library(sfheaders)
67
#'
68
#' sf_flights <- sfheaders::sf_point( flights, x = "start_lon", y = "start_lat", keep = TRUE )
69
#' destination <- sfheaders::sfc_point( flights, x = "end_lon", y = "end_lat" )
70
#'
71
#' sf_flights$destination <- destination
72
#'
73
#' mapdeck() %>%
74
#'  add_greatcircle(
75
#'    data = sf_flights
76
#'    , origin = 'geometry'
77
#'    , destination = 'destination'
78
#'    , layer_id = 'greatcircles'
79
#'    , stroke_from = "airport1"
80
#'    , stroke_to = "airport2"
81
#' )
82
#' }
83
#'
84
#' @details
85
#'
86
#' \code{add_greatcircle} supports POINT sf objects
87
#'
88
#' MULTIPOINT objects will be treated as single points. That is, if an sf objet
89
#' has one row with a MULTIPOINT object consisting of two points, this will
90
#' be expanded to two rows of single POINTs.
91
#' Therefore, if the origin is a MULTIPOINT of two points, and the destination is
92
#' a single POINT, the code will error as there will be an uneven number of rows
93
#'
94
#' @export
95
add_greatcircle <- function(
96
	map,
97
	data = get_map_data(map),
98
	layer_id = NULL,
99
	origin,
100
	destination,
101
	id = NULL,
102
	stroke_from = NULL,
103
	stroke_from_opacity = NULL,
104
	stroke_to = NULL,
105
	stroke_to_opacity = NULL,
106
	stroke_width = NULL,
107
	wrap_longitude = FALSE,
108
	tooltip = NULL,
109
	auto_highlight = FALSE,
110
	highlight_colour = "#AAFFFFFF",
111
	legend = F,
112
	legend_options = NULL,
113
	legend_format = NULL,
114
	palette = "viridis",
115
	na_colour = "#808080FF",
116
	update_view = TRUE,
117
	focus_layer = FALSE,
118
	transitions = NULL,
119
	digits = 6
120
) {
121 0
	brush_radius = NULL
122

123 0
	l <- list()
124 0
	l[["origin"]] <- force(origin)
125 0
	l[["destination"]] <- force(destination)
126 0
	l[["stroke_from"]] <- force(stroke_from)
127 0
	l[["stroke_to"]] <- force(stroke_to)
128 0
	l[["stroke_from_opacity"]] <- force(stroke_from_opacity)
129 0
	l[["stroke_to_opacity"]] <- force(stroke_to_opacity)
130 0
	l[["stroke_width"]] <- force(stroke_width)
131 0
	l[["tooltip"]] <- force(tooltip)
132 0
	l[["id"]] <- force(id)
133 0
	l[["na_colour"]] <- force(na_colour)
134

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

140 0
	bbox <- init_bbox()
141 0
	update_view <- force( update_view )
142 0
	focus_layer <- force( focus_layer )
143 0
	wrap_longitude <- force( wrap_longitude )
144

145 0
	layer_id <- layerId(layer_id, "greatcircle")
146 0
	checkHexAlpha(highlight_colour)
147

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

153 0
	if( !is.null(l[["bbox"]] ) ) {
154 0
		bbox <- l[["bbox"]]
155 0
		l[["bbox"]] <- NULL
156
	}
157

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

161 0
	jsfunc <- "add_greatcircle_geo"
162 0
	map <- addDependency(map, mapdeckGreatCircleDependency())
163

164

165 0
	if ( tp == "sf" ) {
166 0
		geometry_column <- c( "origin", "destination" )
167 0
		shape <- rcpp_od_geojson( data, l, geometry_column, digits, "greatcircle" )
168 0
	} else if ( tp == "df" ) {
169 0
		geometry_column <- list( origin = c("start_lon", "start_lat","start_elev"), destination = c("end_lon", "end_lat","end_elev") )
170 0
		shape <- rcpp_od_geojson_df( data, l, geometry_column, digits, "greatcircle" )
171 0
	} else if ( tp == "sfencoded" ) {
172 0
		geometry_column <- c("origin", "destination")
173 0
		shape <- rcpp_od_polyline( data, l, geometry_column, "greatcircle" )
174 0
		jsfunc <- "add_greatcircle_polyline"
175
	}
176

177 0
	js_transition <- resolve_transitions( transitions, "greatcircle" )
178 0
	if( inherits( legend, "json" ) ) {
179 0
		shape[["legend"]] <- legend
180
	} else {
181 0
		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
182
	}
183

184 0
	invoke_method(
185 0
		map, jsfunc, map_type( map ), shape[["data"]], layer_id, auto_highlight,
186 0
		highlight_colour, shape[["legend"]], bbox, update_view, focus_layer, js_transition,
187 0
		wrap_longitude, brush_radius
188
	)
189
}
190

191

192

193
#' Clear greatcircle
194
#'
195
#' @rdname clear
196
#' @param map a mapdeck map object
197
#' @param layer_id the layer_id of the layer you want to clear
198
#' @export
199
clear_greatcircle <- function( map, layer_id = NULL ) {
200 0
	layer_id <- layerId(layer_id, "greatcircle")
201 0
	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "greatcircle" )
202
}

Read our documentation on viewing source code .

Loading