rebasing with master for #128 and #129

.Rbuildignore

@@ -15,3 +15,4 @@
 ^vignettes/tips_tricks.Rmd
 ^vignettes/img/articles/*
 ^vignettes/layers.Rmd
+^vignettes/google_map.Rmd

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: mapdeck
 Type: Package
 Title: Interactive Maps Using 'Mapbox GL JS' and 'Deck.gl'
-Version: 0.2.1001
-Date: 2019-01-22
+Version: 0.2.1005
+Date: 2019-04-01
 Authors@R: c(
     person("David", "Cooley", ,"[email protected]", role = c("aut", "cre"))
     )
@@ -22,7 +22,7 @@ Imports:
     googlePolylines (>= 0.7.2),
     htmltools,
     htmlwidgets,
-    jsonify (>= 0.2.0),
+    jsonify (>= 0.2.1),
     magrittr,
     Rcpp,
     shiny

NAMESPACE

@@ -7,6 +7,8 @@ S3method(get_box,sf)
 S3method(get_box,sfencoded)
 S3method(get_od_box,data.frame)
 S3method(get_od_box,sf)
+S3method(mapdeck_legend,default)
+S3method(mapdeck_legend,mapdeck_legend)
 S3method(normaliseMultiSfData,sf)
 S3method(normaliseSfData,default)
 S3method(normaliseSfData,sf)
@@ -35,7 +37,11 @@ S3method(resolve_od_data,sfencoded)
 S3method(resolve_od_data,sfencodedLite)
 export("%>%")
 export(add_arc)
+export(add_bitmap)
+export(add_column)
+export(add_dependencies)
 export(add_geojson)
+export(add_greatcircle)
 export(add_grid)
 export(add_hexagon)
 export(add_line)
@@ -50,7 +56,10 @@ export(add_sf)
 export(add_text)
 export(add_title)
 export(clear_arc)
+export(clear_bitmap)
+export(clear_column)
 export(clear_geojson)
+export(clear_greatcircle)
 export(clear_grid)
 export(clear_hexagon)
 export(clear_legend)
@@ -65,13 +74,16 @@ export(clear_title)
 export(clear_tokens)
 export(invoke_mapbox_method)
 export(invoke_method)
+export(legend_element)
 export(mapbox)
 export(mapboxOutput)
 export(mapbox_dispatch)
 export(mapbox_update)
 export(mapdeck)
 export(mapdeckOutput)
+export(mapdeck_dependencies)
 export(mapdeck_dispatch)
+export(mapdeck_legend)
 export(mapdeck_style)
 export(mapdeck_tokens)
 export(mapdeck_update)

NEWS.md

@@ -1,5 +1,12 @@
 # mapdeck 0.3
 
+* Google Map supported
+* `mapdeck_legend` and `legend_element` for manually creating legends
+* `add_column()` to draw columns (as any polygon shape)
+* `add_text()` gets `billbaord`, `font_family`, `font_weight`
+* `add_greatcircles()` to draw flat great circles
+* `add_line` width docs updated to say 'metres'
+* `add_arc` gets `tilt` and `height` arguments
 * `add_arc` gets `brush_radius` argument for brushing
 * opacity values can be in [0,1) OR [0,255]
 * layeres work without an access token

R/RcppExports.R

@@ -13,10 +13,34 @@ rcpp_arc_polyline <- function(data, params, geometry_columns) {
     .Call(`_mapdeck_rcpp_arc_polyline`, data, params, geometry_columns)
 }
 
+rcpp_column_geojson <- function(data, params, geometry_columns) {
+    .Call(`_mapdeck_rcpp_column_geojson`, data, params, geometry_columns)
+}
+
+rcpp_column_geojson_df <- function(data, params, geometry_columns) {
+    .Call(`_mapdeck_rcpp_column_geojson_df`, data, params, geometry_columns)
+}
+
+rcpp_column_polyline <- function(data, params, geometry_columns) {
+    .Call(`_mapdeck_rcpp_column_polyline`, data, params, geometry_columns)
+}
+
 rcpp_geojson_geojson <- function(data, params, geometry_column) {
     .Call(`_mapdeck_rcpp_geojson_geojson`, data, params, geometry_column)
 }
 
+rcpp_greatcircle_geojson <- function(data, params, geometry_columns, digits) {
+    .Call(`_mapdeck_rcpp_greatcircle_geojson`, data, params, geometry_columns, digits)
+}
+
+rcpp_greatcircle_geojson_df <- function(data, params, geometry_columns, digits) {
+    .Call(`_mapdeck_rcpp_greatcircle_geojson_df`, data, params, geometry_columns, digits)
+}
+
+rcpp_greatcircle_polyline <- function(data, params, geometry_columns) {
+    .Call(`_mapdeck_rcpp_greatcircle_polyline`, data, params, geometry_columns)
+}
+
 rcpp_grid_geojson <- function(data, params, geometry_column, digits) {
     .Call(`_mapdeck_rcpp_grid_geojson`, data, params, geometry_column, digits)
 }

R/legend.R

@@ -11,3 +11,97 @@
 clear_legend <- function( map_id, layer_id ) {
 	invoke_method( map_id, "md_clear_legend", layer_id );
 }
+
+
+#' Mapdeck Legend
+#'
+#' Constructs legend elements into the correct JSON format for plotting on the map
+#'
+#' @param legend_elements vector of legend elements (made from \link{legend_element})
+#'
+#' @examples
+#' l1 <- legend_element(
+#' 	variables = c("a","b")
+#' 	, colours = c("#00FF00","#FF0000")
+#' 	, colour_type = "fill"
+#' 	, variable_type = "category"
+#' 	, title = "my title"
+#' )
+#'
+#' mapdeck_legend(l1)
+#'
+#' @seealso \link{legend_element}
+#'
+#' @export
+mapdeck_legend <- function(legend_elements) UseMethod("mapdeck_legend")
+
+#' @export
+mapdeck_legend.mapdeck_legend <- function( legend_elements ) jsonify::to_json(legend_elements)
+
+#' @export
+mapdeck_legend.default <- function( legend_elements ) {
+	stop("mapdeck_legend will only work on objects created with legend_element")
+}
+
+#' Legend Element
+#'
+#' Creates a mapdeck legend element for when you want to manually specify a legend (using \link{mapdeck_legend})
+#'
+#' @param variables variables assigned to colours
+#' @param colours vector of hex colours assigned to variables
+#' @param colour_type one of "fill" or "stroke"
+#' @param variable_type one of category (discrete) or gradient (continuous)
+#' @param title string used as the legend title
+#' @param css string of css to control appearance.
+#'
+#' @seealso \link{mapdeck_legend}
+#'
+#' @examples
+#'
+#' l1 <- legend_element(
+#' 	variables = c("a","b")
+#' 	, colours = c("#00FF00","#FF0000")
+#' 	, colour_type = "fill"
+#' 	, variable_type = "category"
+#' 	, title = "my title"
+#' )
+#'
+#' @export
+legend_element <- function(
+	variables,
+	colours,
+	colour_type = c("fill", "stroke"),
+	variable_type = c("category", "gradient"),
+	title = "",
+	css = ""
+	) {
+
+	if( length( colours ) != length( variables ) ) {
+		stop("colours and variables should be the same length")
+	}
+
+	colour_type <- legend_colour_type( colour_type )
+
+	l <- list(
+		colour = colours
+		, variable = variables
+		, colourType = colour_type
+		, type = variable_type
+		, title = title
+		, css = css
+	)
+
+	l <- list( l )
+	names(l) <- colour_type
+	attr(l, "class") <- c("mapdeck_legend", attr(l, "class"))
+	return(l)
+}
+
+
+legend_colour_type <- function( colour_type ) {
+	switch(
+		colour_type
+		, "fill" = "fill_colour"
+		, "stroke" = "stroke_colour"
+	)
+}

R/map_data.R

@@ -179,8 +179,8 @@ get_box.sf <- function( data, l ) {
 #' @export
 get_box.data.frame <- function( data, l ) {
 
-	lat <- data[, l[["lat"]] ]
-	lon <- data[, l[["lon"]] ]
+	lat <- data[, l[["lat"]], drop = TRUE ]
+	lon <- data[, l[["lon"]], drop = TRUE ]
 	xmin <- min(lon); xmax <- max(lon)
 	ymin <- min(lat); ymax <- max(lat)
 	bbox <- list( c(xmin, ymin), c(xmax, ymax) )
@@ -205,8 +205,10 @@ get_od_box.sf <- function( data, l ) {
 
 #' @export
 get_od_box.data.frame <- function( data, l ) {
-	lon <- c( data[, l[["origin"]][1] ], data[, l[["destination"]][1]] )
-	lat <- c( data[, l[["origin"]][2] ], data[, l[["destination"]][2]] )
+
+	lon <- c( data[, l[["origin"]][1], drop = TRUE ], data[, l[["destination"]][1], drop = TRUE ] )
+	lat <- c( data[, l[["origin"]][2], drop = TRUE ], data[, l[["destination"]][2], drop = TRUE ] )
+
 	xmin <- min(lon); xmax <- max(lon)
 	ymin <- min(lat); ymax <- max(lat)
 	bbox <- list( c(xmin, ymin), c(xmax, ymax) )
@@ -317,7 +319,11 @@ resolve_palette <- function( l, palette ) {
 
 
 resolve_legend <- function( l, legend ) {
-	l[['legend']] <- legend
+	if(inherits( legend, "json" ) ) {
+		l[["legend"]] <- FALSE
+	} else {
+	  l[['legend']] <- legend
+	}
 	return( l )
 }
 

R/map_layer_arc.R

@@ -4,7 +4,8 @@ mapdeckArcDependency <- function() {
 			name = "arc",
 			version = "1.0.0",
 			src = system.file("htmlwidgets/lib/arc", package = "mapdeck"),
-			script = c("arc.js")
+			script = c("arc.js"),
+			all_files = FALSE
 		)
 	)
 }
@@ -15,7 +16,8 @@ mapdeckArcBrushDependency <- function() {
 			name = "arc_brush",
 			version = "1.0.0",
 			src = system.file("htmlwidgets/lib/arc_brush", package = "mapdeck"),
-			script = c("arc_brush.js")
+			script = c("arc_brush.js"),
+			all_files = FALSE
 		)
 	)
 }
@@ -36,18 +38,24 @@ mapdeckArcBrushDependency <- function() {
 #' @param stroke_from variable or hex colour to use as the staring stroke colour
 #' @param stroke_from_opacity Either a string specifying the
 #' column of \code{data} containing the stroke opacity of each shape, or a value
-#' between 1 and 255 to be applied to all the shapes
+#' between 1 and 255 to be applied to all the shapes. If a hex-string is used as the
+#' colour, this argument is ignored and you should include the alpha on the hex string
 #' @param stroke_to variable or hex colour to use as the ending stroke colour
 #' @param stroke_to_opacity Either a string specifying the
 #' column of \code{data} containing the stroke opacity of each shape, or a value
-#' between 1 and 255 to be applied to all the shapes
+#' between 1 and 255 to be applied to all the shapes. If a hex-string is used as the
+#' colour, this argument is ignored and you should include the alpha on the hex string
 #' @param stroke_width width of the stroke in pixels
+#' @param height value to multiply the height.
+#' @param tilt value to tilt the arcs to the side, in degrees [-90, 90]
 #' @param tooltip variable of \code{data} containing text or HTML to render as a tooltip
 #' @param auto_highlight logical indicating if the shape under the mouse should auto-highlight
 #' @param highlight_colour hex string colour to use for highlighting. Must contain the alpha component.
 #' @param palette string or matrix. String will be one of \code{colourvalues::colour_palettes()}.
-#' A matrix is a 3 or 4 column numeric matrix of values between [0, 255],
-#' where the 4th column represents the alpha.
+#' A matrix must have at least 5 rows, and 3 or 4 columns of values between [0, 255],
+#' where the 4th column represents the alpha. You can use a named list to specify a different
+#' palette for different colour options (where available),
+#'  e.g. list(fill_colour = "viridis", stroke_colour = "inferno")
 #' @param na_colour hex string colour to use for NA values
 #' @param legend either a logical indiciating if the legend(s) should be displayed, or
 #' a named list indicating which colour attributes should be included in the legend.
@@ -121,14 +129,15 @@ mapdeckArcBrushDependency <- function() {
 #'
 #' ## You need a valid access token from Mapbox
 #' key <- 'abc'
+#' set_token( key )
 #'
 #' url <- 'https://raw.githubusercontent.com/plotly/datasets/master/2011_february_aa_flight_paths.csv'
 #' flights <- read.csv(url)
 #' flights$id <- seq_len(nrow(flights))
 #' flights$stroke <- sample(1:3, size = nrow(flights), replace = T)
 #' flights$info <- paste0("<b>",flights$airport1, " - ", flights$airport2, "</b>")
 #'
-#' mapdeck( token = key, style = mapdeck_style("dark"), pitch = 45 ) %>%
+#' mapdeck( style = mapdeck_style("dark"), pitch = 45 ) %>%
 #'   add_arc(
 #'   data = flights
 #'   , layer_id = "arc_layer"
@@ -220,6 +229,8 @@ add_arc <- function(
 	stroke_to = NULL,
 	stroke_to_opacity = NULL,
 	stroke_width = NULL,
+	tilt = NULL,
+	height = NULL,
 	tooltip = NULL,
 	auto_highlight = FALSE,
 	highlight_colour = "#AAFFFFFF",
@@ -243,6 +254,8 @@ add_arc <- function(
 	l[["stroke_from_opacity"]] <- force(stroke_from_opacity)
 	l[["stroke_to_opacity"]] <- force(stroke_to_opacity)
 	l[["stroke_width"]] <- force(stroke_width)
+	l[["tilt"]] <- force(tilt)
+	l[["height"]] <- force(height)
 	l[["tooltip"]] <- force(tooltip)
 	l[["id"]] <- force(id)
 	l[["na_colour"]] <- force(na_colour)
@@ -297,10 +310,14 @@ add_arc <- function(
   }
 
 	js_transition <- resolve_transitions( transitions, "arc" )
-	shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
+	if( inherits( legend, "json" ) ) {
+		shape[["legend"]] <- legend
+	} else {
+		shape[["legend"]] <- resolve_legend_format( shape[["legend"]], legend_format )
+	}
 
 	invoke_method(
-		map, jsfunc, shape[["data"]], layer_id, auto_highlight,
+		map, jsfunc, map_type( map ), shape[["data"]], layer_id, auto_highlight,
 		highlight_colour, shape[["legend"]], bbox, update_view, focus_layer, js_transition,
 		brush_radius
 		)
@@ -317,5 +334,5 @@ add_arc <- function(
 #' @export
 clear_arc <- function( map, layer_id = NULL ) {
 	layer_id <- layerId(layer_id, "arc")
-	invoke_method(map, "md_layer_clear", layer_id, "arc" )
+	invoke_method(map, "md_layer_clear", map_type( map ), layer_id, "arc" )
 }