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

12

13
#' Add Trips
14
#'
15
#' The Trips Layer takes an sf object with Z (elevation) and M (time) attributes and renders
16
#' it as animated trips
17
#'
18
#' @inheritParams add_path
19
#' @param data sf object with XYZM dimensions.
20
#' @param stroke_colour variable of data or hex colour for the stroke.
21
#' @param trail_length how long it takes for the trail to completely fade out
22
#' (in same units as timestamps )
23
#' @param opacity single value in [0,1]
24
#' @param start_time the minimum timestamp
25
#' @param end_time the maximum timestamp
26
#' @param animation_speed speed of animation
27
#' @inheritSection add_arc legend
28
#' @inheritSection add_arc id
29
#'
30
#'
31
#' @examples
32
#' \donttest{
33
#'
34
#' set_token( "MAPBOX_TOKEN")
35
#' sf <- city_trail
36
#'
37
#' mapdeck(
38
#' location = c(145, -37.8)
39
#' , zoom = 10
40
#' , style = mapdeck_style("dark")
41
#' ) %>%
42
#'  add_trips(
43
#'    data = sf
44
#'    , animation_speed = 2000
45
#'    , trail_length = 1000
46
#'    , stroke_colour = "#FFFFFF"
47
#' )
48
#'
49
#' }
50
#'
51
#' @details
52
#'
53
#' \code{add_trips} supports LINESTRING and MULTILINESTRING sf objects
54
#'
55
#' @export
56
add_trips <- function(
57
	map,
58
	data = get_map_data(map),
59
	stroke_colour = NULL,
60
	stroke_width = NULL,
61
	opacity = 0.3,
62
	palette = "viridis",
63
	trail_length = 180,
64
	start_time = get_m_range_start( data ),
65
	end_time = get_m_range_end( data ),
66
	animation_speed = 30,
67
	layer_id = NULL,
68
	legend = FALSE,
69
	legend_options = NULL,
70
	legend_format = NULL,
71
	digits = 6
72
) {
73

74 0
	experimental_layer("trips")
75

76 0
	l <- list()
77 0
	l[["stroke_colour"]] <- force( stroke_colour )
78 0
	l[["stroke_width"]] <- force( stroke_width )
79

80 0
	l <- resolve_palette( l, palette )
81 0
	l <- resolve_legend( l, legend )
82 0
	l <- resolve_legend_options( l, legend_options )
83 0
	l <- resolve_data( data, l, c("LINESTRING") )
84

85
	# bbox <- init_bbox()
86
	#update_view <- force( update_view )
87
	#focus_layer <- force( focus_layer )
88

89 0
	if ( !is.null(l[["data"]]) ) {
90 0
		data <- l[["data"]]
91 0
		l[["data"]] <- NULL
92
	}
93

94
	# if( !is.null(l[["bbox"]] ) ) {
95
	# 	bbox <- l[["bbox"]]
96
	# 	l[["bbox"]] <- NULL
97
	# }
98

99 0
	layer_id <- layerId(layer_id, "trips")
100
	# checkHexAlpha( highlight_colour )
101

102 0
	map <- addDependency(map, mapdeckTripsDependency())
103

104 0
	tp <- l[["data_type"]]
105 0
	l[["data_type"]] <- NULL
106

107 0
	if ( tp == "sf" ) {
108 0
		geometry_column <- c( "geometry" ) ## This is where we woudl also specify 'origin' or 'destination'
109 0
		shape <- rcpp_path_geojson( data, l, geometry_column, digits, "trips" )
110 0
		jsfunc <- "add_trips_geo"
111
	} else {
112 0
		stop("mapdeck - currently only sf objects are supported for the trips layer")
113
	}
114

115
	# js_transitions <- resolve_transitions( transitions, "path" )
116 0
	shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
117

118 0
	invoke_method(
119 0
		map, jsfunc, map_type( map ), shape[["data"]], opacity, layer_id, trail_length,
120 0
		start_time, end_time, animation_speed, shape[["legend"]]
121
	)
122
}
123

124

125
#' @rdname clear
126
#' @export
127
clear_trips <- function( map, layer_id = NULL) {
128 0
	layer_id <- layerId(layer_id, "trips")
129 0
	invoke_method(map, "md_layer_clear", layer_id, "trips" )
130
}
131

132

133 0
get_m_range_start <- function(x) unname( get_m_range(x)[1] )
134

135 0
get_m_range_end <- function(x) unname( get_m_range(x)[2] )
136

137 0
get_m_range <- function( x ) UseMethod("get_m_range")
138

139
## TODO error handle if doesn't exist
140
## TODO get the geometry column from the sf attributes
141

142
#' @export
143
get_m_range.sf <- function( x ) {
144

145 0
	geometry <- attr( x, "sf_column" )
146 0
	if( is.null( attr( x[[geometry]], "m_range" ) ) ) {
147 0
		stop("mapdeck - m_range attribute not set; please define the start_time and end_time")
148
	}
149

150 0
	attr( x[[geometry]], "m_range")
151
}
152
#' @export
153 0
get_m_range.default <- function( x ) stop("mapdeck - only sf objects with ZM attributes are supported for the trips layer")
154

155

Read our documentation on viewing source code .

Loading