SymbolixAU / mapdeck
1

2 1
init_bbox <- function() return(  list(c(-180,-90),c(180,90)) )
3

4
# sfrow <- function( sf , sfc_type ) {
5
# 	geom_column <- attr(sf, "sf_column")
6
# 	return( which(vapply(sf[[geom_column]], function(x) attr(x, "class")[[2]], "") %in% sfc_type ) )
7
# }
8

9 1
resolve_od_data <- function( data, l, origin, destination ) UseMethod("resolve_od_data")
10

11
#' @export
12
resolve_od_data.sf <- function( data, l, origin, destination ) {
13 0
	if ( is.null( l[["origin"]] ) || is.null( l[["destination"]] ) ) {
14 0
		stop("mapdeck - origin and destination columns required")
15
	}
16

17
	## downcast each side of the sf object to POINT
18 0
	attr( data, "sf_column" ) <- origin
19 0
	data <- sfheaders::sf_cast( data, "POINT" )
20

21 0
	attr( data, "sf_column" ) <- destination
22 0
	data <- sfheaders::sf_cast( data, "POINT" )
23

24 0
	l[["data"]] <- data
25

26

27 0
	l[["data_type"]] <- "sf"
28 0
	l[["bbox"]] <- get_od_box( data, l )
29 0
	return( l )
30
}
31

32
#' @export
33
resolve_od_data.sfencoded <- function( data, l, origin, destination ) {
34
	# if ( is.null( l[["origin"]] ) || is.null( l[["destination"]] ) ) {
35
	# 	stop("origin and destination columns required")
36
	# }
37
	#
38
	# #data <- data[ googlePolylines::geometryRow(data, geometry = sf_geom, multi = TRUE), ]
39
	#
40
	# # l[["data_type"]] <- "sfencoded"
41
	# # l[["data"]] <- data
42
	# l <- resolve_od_data.sfencodedLite( data, l, origin, destination )
43
	# return( l )
44 0
  stop("mapdeck - data type not yet for supported origin-destination plots")
45
}
46

47
#' @export
48
resolve_od_data.sfencodedLite <- function( data, l, origin, destination ) {
49
#
50
# 	# if ( sf_geom != "POLYGON" ) {   ## TODO( I don't like this)
51
# 	# 	data <- unlistMultiGeometry( data, polyline )  ## TODO( move this to C++)
52
# 	# }
53
#
54
# 	data <- unlistMultiGeometry( data, origin )
55
# 	data <- unlistMultiGeometry( data, destination )
56
#
57
# 	l[["origin"]] <- origin
58
# 	l[["destination"]] <- destination
59
#
60
# 	l[["data_type"]] <- "sfencoded"
61
# 	l[["data"]] <- data ## attach the data becaue it gets modified and it needs to be returend
62
# 	return( l )
63 0
	stop("mapdeck - data type not supported")
64
}
65

66
#' @export
67
resolve_od_data.data.frame <- function( data, l, origin, destination ) {
68 1
	if ( is.null( l[["origin"]] ) || is.null( l[["destination"]] ) ) {
69 0
		stop("mapdeck - origin and destination columns required")
70
	}
71

72 1
	if( length( origin ) == 2 ) {
73 1
		l[["start_lon"]] <- origin[1]
74 1
		l[["start_lat"]] <- origin[2]
75 1
		l[["start_elev"]] <- 0
76 1
	} else if ( length( origin ) == 3 ) {
77 0
		l[["start_lon"]] <- origin[1]
78 0
		l[["start_lat"]] <- origin[2]
79 0
		l[["start_elev"]] <- origin[3]
80
	} else {
81 0
		stop("mapdeck - origin and destination columns should contain lon & lat, and optionally elevation columns")
82
	}
83

84 1
	if( length( destination ) == 2 ) {
85 1
		l[["end_lon"]] <- destination[1]
86 1
		l[["end_lat"]] <- destination[2]
87 1
		l[["end_elev"]] <- 0
88 1
	} else if ( length( destination ) == 3 ) {
89 0
		l[["end_lon"]] <- destination[1]
90 0
		l[["end_lat"]] <- destination[2]
91 0
		l[["end_elev"]] <- destination[3]
92
	} else {
93 0
		stop("mapdeck - origin and destination columns should contain lon & lat, and optionally elevation columns")
94
	}
95

96
	# if( length(origin) != 2 | length(destination) != 2 ) {
97
	# 	stop("mapdeck - origin and destination columns should both contain lon & lat values")
98
	# }
99

100 1
	l[["data_type"]] <- "df"
101 1
	l[["bbox"]] <- get_od_box( data, l )
102

103
	# l[["start_lon"]] <- origin[1]
104
	# l[["start_lat"]] <- origin[2]
105
	# l[["end_lon"]] <- destination[1]
106
	# l[["end_lat"]] <- destination[2]
107

108 1
	l[["origin"]] <- NULL
109 1
	l[["destination"]] <- NULL
110

111 1
	return( l )
112
}
113

114 1
resolve_elevation_data <- function( data, l, elevation, sf_geom ) UseMethod( "resolve_elevation_data" )
115

116
#' @export
117
resolve_elevation_data.data.frame <- function( data, l, elevation, sf_geom ) {
118

119 1
	if ( !is.null( l[["polyline"]] ) ) {
120
		## the user supplied a polyline in a data.frame, so we need to allow this through
121 0
		l[["data_type"]] <- "sfencoded"
122
	} else {
123 1
	  if ( !(all(sf_geom %in% c( "POINT", "MULTIPOINT") ) ) )
124 1
		  stop("mapdeck - unsupported data type")
125

126 1
		l[["data_type"]] <- "df"
127 1
		l[["bbox"]] <- get_box( data, l )
128
	}
129

130 1
	l[["data"]] <- data
131

132 1
	return( l )
133
}
134

135
#' @export
136
resolve_elevation_data.sf <- function( data, l, elevation, sf_geom ) {
137 0
	return(
138 0
		resolve_data( data, l, sf_geom )
139
	)
140
}
141

142
#' @export
143
resolve_elevation_data.sfencoded <- function( data, l, elevation, sf_geom ) {
144

145 0
	data <- data[ googlePolylines::geometryRow(data, geometry = sf_geom[1], multi = TRUE), ]
146

147 0
	l[["data_type"]] <- "sfencoded"
148 0
	l[["bbox"]] <- get_box( data, l )
149 0
	l[["data"]] <- data
150 0
	l <- resolve_elevation_data.sfencodedLite( data, l, elevation, sf_geom )
151 0
	return( l )
152
}
153

154
#' @export
155
resolve_elevation_data.sfencodedLite <- function( data, l, elevation, sf_geom ) {
156 0
	polyline <- attr( data, "encoded_column")
157 0
	if ( !all(sf_geom %in% c("POLYGON","MULTIPOLYGON") ) ) {   ## TODO( I don't like this)
158 0
		data <- unlistMultiGeometry( data, polyline )  ## TODO( move this to C++)
159
	}
160

161 0
	l[["polyline"]] <- polyline
162

163 0
	l[["data_type"]] <- "sfencoded"
164 0
	l[["data"]] <- data ## attach the data becaue it gets modified and it needs to be returend
165 0
	return( l )
166
}
167

168
## data using a single geometry ()
169 1
resolve_data <- function( data, l, sf_geom ) UseMethod( "resolve_data" )
170

171
# sfc_type <- function( sf, sfc_col ) {
172
# 	cls <- attr(sf[[sfc_col]], "class")
173
# 	return( gsub("sfc_", "", cls[1] ) )
174
# }
175

176
##
177
# sf_needs_subsetting <- function( data, sfc_col, sf_geom ) {
178
# 	return( !sfc_type( data, sfc_col ) %in% toupper( sf_geom ) )
179
# }
180

181

182
#' @export
183
resolve_data.mesh3d <- function( data, l, sf_geom ) {
184 0
	l[["data"]] <- data
185 0
	l[["bbox"]] <- get_box( data, l )
186 0
	l[["geometry"]] <- "geometry"
187 0
	l[["data_type"]] <- "mesh"
188 0
	return(l)
189
}
190
#' @export
191
resolve_data.quadmesh <- function( data, l, sf_geom ) {
192 0
	l[["data"]] <- data
193 0
	l[["bbox"]] <- get_box( data, l )
194 0
	l[["geometry"]] <- "geometry"
195 0
	l[["data_type"]] <- "mesh"
196 0
	return(l)
197
}
198

199
## use the specificed st_geometry column
200
#' @export
201
resolve_data.sf <- function( data, l, sf_geom ) {
202

203 0
	sfc_col <- attr( data, "sf_column" )
204 0
	l[["geometry"]] <- sfc_col
205

206
	# if( sf_needs_subsetting( data, sfc_col, sf_geom ) ) {
207
	# 	l[["data"]] <- data[ sfrow(data, sf_geom) , ]
208
	# }
209

210
	## TODO: move to c++
211
	## only cast if it's needed
212 0
	cls <- attr( data[[ sfc_col ]], "class" )
213

214 0
	if( is.null( cls ) ) {
215 0
		stop("mapdeck - invalid sf object; have you loaded library(sf)?")
216
	}
217

218 0
	cls <- gsub("sfc_", "", cls[1])
219 0
	if( cls != sf_geom ) {
220 0
		l[["data"]] <- sfheaders::sf_cast( data, sf_geom )
221
	}
222

223 0
	l[["bbox"]] <- get_box( data, l )
224 0
	l[["data_type"]] <- "sf"
225 0
	return(l)
226
}
227

228 1
get_box <- function( data, l ) UseMethod("get_box")
229

230
#' @export
231
get_box.mesh3d <- function( data, l ) {
232 0
	xrange <- range(data[["vb"]][1L, ], na.rm = TRUE)
233 0
	yrange <- range(data[["vb"]][2L, ], na.rm = TRUE)
234

235 0
	bbox <- list(
236 0
		c(xrange[1L], yrange[1L]), c(xrange[2L], yrange[2L])
237
	)
238 0
	return( jsonify::to_json( bbox ) )
239
}
240
#' @export
241
get_box.quadmesh <- function( data, l ) {
242 0
	md <- data[["raster_metadata"]]
243 0
	if(is.null(md)) {
244 0
		stop("mapdeck - expecting raster_metadata attribute on quadmesh object. Make sure you are using v0.4.0 of quadmesh")
245
	}
246 0
  bbox <- list(
247 0
  	 c(md[["xmn"]], md[["ymn"]]), c(md[["xmx"]], md[["ymx"]])
248
  	 )
249 0
  return( jsonify::to_json( bbox ) )
250
}
251

252

253
#' @export
254
get_box.sfencoded <- function( data, l ) {
255 0
	bbox <- attr( data, "sfAttributes")[["bbox"]]
256 0
	bbox <- list(c(bbox[1:2]), c(bbox[3:4]))
257 0
	return( jsonify::to_json( bbox ) )
258
}
259

260
#' @export
261
get_box.sf <- function( data, l ) {
262 0
	bbox <- attr(data[[ l[["geometry"]] ]], "bbox")
263 0
	bbox <- list(c(bbox[1:2]), c(bbox[3:4]))
264 0
	return( jsonify::to_json( bbox ) )
265
}
266

267
#' @export
268
get_box.data.frame <- function( data, l ) {
269

270 1
	lat <- data[, l[["lat"]], drop = TRUE ]
271 1
	lon <- data[, l[["lon"]], drop = TRUE ]
272 1
	xmin <- min(lon); xmax <- max(lon)
273 1
	ymin <- min(lat); ymax <- max(lat)
274 1
	bbox <- list( c(xmin, ymin), c(xmax, ymax) )
275 1
	return( jsonify::to_json( bbox ) )
276
}
277

278 1
get_od_box <- function( data, l ) UseMethod("get_od_box")
279

280
#' @export
281
get_od_box.sf <- function( data, l ) {
282

283 0
	obbox <- attr( data[[ l[["origin"]] ]], "bbox" )
284 0
	dbbox <- attr( data[[ l[["destination"]] ]], "bbox" )
285

286 0
	xmin <- min( obbox[1], dbbox[1] )
287 0
	ymin <- min( obbox[2], dbbox[2] )
288 0
	xmax <- max( obbox[3], dbbox[3] )
289 0
	ymax <- max( obbox[4], dbbox[4] )
290 0
	bbox <- list( c(xmin, ymin), c(xmax, ymax) )
291 0
	return( jsonify::to_json( bbox ) )
292
}
293

294
#' @export
295
get_od_box.data.frame <- function( data, l ) {
296

297 1
	lon <- c( data[, l[["origin"]][1], drop = TRUE ], data[, l[["destination"]][1], drop = TRUE ] )
298 1
	lat <- c( data[, l[["origin"]][2], drop = TRUE ], data[, l[["destination"]][2], drop = TRUE ] )
299

300 1
	xmin <- min(lon); xmax <- max(lon)
301 1
	ymin <- min(lat); ymax <- max(lat)
302 1
	bbox <- list( c(xmin, ymin), c(xmax, ymax) )
303 1
	return( jsonify::to_json( bbox ) )
304
}
305

306
#' @export
307
resolve_data.sfencoded <- function( data, l, sf_geom ) {
308

309 0
	if ( "POLYGON" %in% sf_geom & !("list" %in% attr( data[[ attr( data, "encoded_column") ]], "class" )) ) {
310 0
		stop("mapdeck - sfencoded POLYGON must be a list column")
311
	}
312

313 0
	if( !attr( data, "sfAttributes" )[["type"]] %in% sf_geom ) {
314 0
	  data <- data[ googlePolylines::geometryRow(data, geometry = sf_geom[1], multi = TRUE), ]
315
	}
316

317 0
	l[["bbox"]] <- get_box( data, l )
318 0
	l[["data_type"]] <- "sfencoded"
319 0
	l[["data"]] <- data
320 0
	l <- resolve_data.sfencodedLite( data, l, sf_geom )
321 0
	return( l )
322
}
323

324
#' @export
325
resolve_data.sfencodedLite <- function( data, l, sf_geom ) {
326

327 0
	polyline <- attr( data, "encoded_column")
328 0
	if ( sf_geom[1] != "POLYGON" ) {   ## TODO( POLYGONs must be a list column I don't like this)
329 0
  	data <- unlistMultiGeometry( data, polyline )  ## TODO( move this to C++)
330
	}
331

332 0
	l[["polyline"]] <- polyline
333 0
	l[["data_type"]] <- "sfencoded"
334 0
	l[["data"]] <- data ## attach the data becaue it gets modified and it needs to be returend
335 0
	return( l )
336
}
337

338
#' @export
339
resolve_data.data.frame <- function( data, l, sf_geom ) {
340

341 1
	if( !inherits(data, "sf") &
342 1
			!inherits(data, "sfencoded") &
343 1
			!inherits(data, "sfencodedLite" ) &
344 1
			is.null( l[["polyline"]] )
345
		) {
346

347 1
		if( is.null(l[["lon"]] ) ) {
348 1
			l[["lon"]] <- find_lon_column( names( data ) )
349
		}
350 1
		if( is.null(l[["lat"]] ) ) {
351 1
			l[["lat"]] <- find_lat_column( names( data ) )
352
		}
353
	}
354

355
	## data.frame will only really work for points, with a lon & lat column
356 1
	if ( !is.null( l[["polyline"]] ) ) {
357
		## the user supplied a polyline in a data.frame, so we need to allow this through
358 1
		l[["data_type"]] <- "sfencoded"
359
	} else {
360 1
		if ( sf_geom[1] != "POINT" )
361 1
			stop("mapdeck - unsupported data type")
362

363 1
		l[["bbox"]] <- get_box( data, l )
364 1
		l[["data_type"]] <- "df"
365
	}
366

367 1
	l[["data"]] <- data
368 1
	return( l )
369
}
370

371
#' @export
372 0
resolve_data.default <- function( data, ... ) stop("mapdeck - This type of data is not supported")
373

374 1
resolve_geojson_data <- function( data, l ) UseMethod("resolve_geojson_data")
375

376
#' @export
377
resolve_geojson_data.sf <- function( data, l ) {
378 0
	geom <- attr(data, "sf_column")
379 0
	l[["geometry"]] <- geom
380 0
	l[["data_type"]] <- "sf"
381 0
	l[["bbox"]] <- get_box( data, l )
382 0
	return( l )
383
}
384

385
#' @export
386
resolve_geojson_data.json <- function( data, l ) {
387 0
  l[["data_type"]] <- "geojson"
388 0
	return( l )
389
}
390

391
#' @export
392
resolve_geojson_data.geojson <- function( data, l ) {
393 1
  l[["data_type"]] <- "geojson"
394 1
  return( l )
395
}
396

397
#' @export
398
resolve_geojson_data.character <- function( data, l ) {
399 0
	if ( is_url( data ) ) {
400 0
		sf <- geojsonsf::geojson_sf( data )
401 0
		l[["data"]] <- sf
402 0
		return(
403 0
			resolve_geojson_data( sf, l )
404
		)
405
	}
406 0
	l[["data_type"]] <- "geojson"
407 0
	return( l )
408
}
409

410
#' @export
411 0
resolve_geojson_data.default <- function( data, l ) stop("mapdeck - I don't know how to handle this type of data")
412

413

414
resolve_palette <- function( l, palette ) {
415 1
	if ( is.function( palette ) ) {
416 0
		warning("Function palettes have been deprecated, reverting to the viridis palette. See the palette arguemnt in the help file for valid arguments")
417
	} else {
418 1
		l[['palette']] <- palette
419
	}
420 1
	return( l )
421
}
422

423

424
resolve_legend <- function( l, legend ) {
425 1
	if(inherits( legend, "json" ) ) {
426 0
		l[["legend"]] <- FALSE
427
	} else {
428 1
	  l[['legend']] <- legend
429
	}
430 1
	return( l )
431
}
432

433
resolve_legend_options <- function( l, legend_options ) {
434 1
	l[["legend_options"]] <- legend_options
435 1
	return( l )
436
}
437

438
resolve_legend_format <- function( l, legend_format ) {
439 1
	if( is.null( legend_format ) ) return( l )
440

441 1
	l <- jsonlite::fromJSON( l )
442

443 1
	for( i in names( legend_format ) ) {
444

445 1
		var <- l[[ i ]][[ "variable" ]]
446 1
		l[[ i ]][[ "variable" ]] <- legend_format[[ i ]]( var )
447
	}
448 1
	l <- jsonify::to_json( l, numeric_dates = FALSE )
449 1
	return( l )
450
}
451

452 0
is_url <- function(geojson) grepl("^https?://", geojson, useBytes=TRUE)
453

454

455
# resolve opacity
456
#
457
resolve_opacity <- function( opacity ) {
458 1
	if( !is.null( opacity ) ) {
459 0
		if( is.numeric( opacity ) ) {
460 0
	    if( opacity < 1 & opacity >= 0 ) opacity <- opacity * 255
461
		}
462
	}
463 1
	return( opacity )
464
}
465

466

467
find_lat_column = function(names) {
468

469 1
	lats = names[grep("^(lat|lats|latitude|latitudes|stop_lat|shape_pt_lat)$", names, ignore.case = TRUE)]
470

471 1
	if (length(lats) == 1) {
472 1
		return(lats)
473
	}
474 0
	stop("mapdeck - could not find latitude column")
475
}
476

477

478
find_lon_column = function(names) {
479

480 1
	lons = names[grep("^(lon|lons|lng|lngs|long|longs|longitude|longitudes|stop_lon|shape_pt_lon)$", names, ignore.case = TRUE)]
481

482 1
	if (length(lons) == 1) {
483 1
		return(lons)
484
	}
485 0
	stop("mapdeck - could not find longitude column")
486
}

Read our documentation on viewing source code .

Loading