v0.1.0

.Rbuildignore

@@ -0,0 +1,12 @@
+# dot-files
+^\..*$
+
+# js
+^js$
+^scripts$
+^node_modules$
+^package\.json$
+^package-lock\.json$
+^babel\.config\.json$
+^tsconfig\.json$
+^webpack\.config\.js$

.editorconfig

@@ -0,0 +1,8 @@
+root = true
+
+[*]
+indent_style = space
+trim_trailing_whitespace = true
+insert_final_newline = true
+charset = utf-8
+indent_size = 2

.gitattributes

@@ -0,0 +1,3 @@
+* text=auto
+inst/htmlwidgets/** -diff
+package-lock.json -diff

.gitignore

@@ -0,0 +1,2 @@
+node_modules
+.vscode

.travis.yml

@@ -0,0 +1,4 @@
+# R for travis: see documentation at https://docs.travis-ci.com/user/languages/r
+
+language: R
+cache: packages

DESCRIPTION

@@ -0,0 +1,23 @@
+Type: Package
+Package: rdeck
+Title: Deck.gl Widget
+Version: 0.1.0
+Authors@R:
+    person(given = "Anthony", family = "North", role = c("aut", "cre"), email = "anthony.jl.north@gmail.com")
+Description: Deck.gl widget for R.
+License: MIT + file LICENSE
+URL: https://github.com/anthonynorth/rdeck
+BugReports: https://github.com/anthonynorth/rdeck/issues
+Depends:
+    R (>= 3.3.0)
+Imports:
+    geojsonsf (>= 1.3.2),
+    htmltools (>= 0.4.0),
+    htmlwidgets (>= 1.5.1),
+    magrittr,
+    sf (>= 0.8.1),
+    snakecase (>= 0.11.0)
+Encoding: UTF-8
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.0.2

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2020 Anthony North
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

NAMESPACE

@@ -0,0 +1,38 @@
+# Generated by roxygen2: do not edit by hand
+
+export("%>%")
+export(JS)
+export(add_arc_layer)
+export(add_bitmap_layer)
+export(add_column_layer)
+export(add_contour_layer)
+export(add_cpu_grid_layer)
+export(add_geojson_layer)
+export(add_gpu_grid_layer)
+export(add_great_circle_layer)
+export(add_grid_cell_layer)
+export(add_grid_layer)
+export(add_h3_cluster_layer)
+export(add_h3_hexagon_layer)
+export(add_heatmap_layer)
+export(add_hexagon_layer)
+export(add_icon_layer)
+export(add_line_layer)
+export(add_path_layer)
+export(add_point_cloud_layer)
+export(add_polygon_layer)
+export(add_s2_layer)
+export(add_scatterplot_layer)
+export(add_scenegraph_layer)
+export(add_screen_grid_layer)
+export(add_simple_mesh_layer)
+export(add_solid_polygon_layer)
+export(add_text_layer)
+export(add_tile3d_layer)
+export(add_tile_layer)
+export(add_trips_layer)
+export(rdeck)
+export(rdeckOutput)
+export(renderRdeck)
+importFrom(htmlwidgets,JS)
+importFrom(magrittr,"%>%")

R/accessor.R

@@ -0,0 +1,84 @@
+#' Create accessors for deck.gl layers.
+#'
+#' @name accessor
+#' @param data `{data.frame}`
+#'  used as expr environment
+#' @param expr `{name | call | atomic}`
+#'  an expression typically created with [base::substitute()]
+#'
+#' @return `{JS | expr}`
+accessor <- function(data, expr) {
+  # no data, or expr is constant
+  if (is.null(data) || !inherits(expr, c("name", "call"))) {
+    return(eval(expr))
+  }
+
+  columns <- names(data)
+
+  # expr is name, but not a column
+  if (is.name(expr) && !(deparse(expr) %in% columns)) {
+    return(eval(expr))
+  }
+
+  # expr is call, but not formula
+  if (is.call(expr) && expr[[1]] != "~") {
+    return(eval(expr))
+  }
+
+  # visit name
+  visit_name <- function(expr) {
+    if (deparse(expr) %in% columns) {
+      name <- paste0(
+        "data.frame[\"", deparse(expr, backtick = FALSE), "\"][index]"
+      ) %>%
+        as.name()
+      return(name)
+    }
+
+    expr
+  }
+
+  # visit call
+  visit_call <- function(expr) {
+    call_name <- expr[[1]]
+    call_args <- as.list(expr)[-1] %>%
+      lapply(function(x) {
+        if (is.call(x)) {
+          visit_call(x)
+        } else if (is.name(x)) {
+          visit_name(x)
+        } else {
+          x
+        }
+      })
+
+    new_call <- as.call(c(call_name, call_args))
+
+    if (new_call[1] == "c()") {
+      name <- deparse(new_call, backtick = FALSE) %>%
+        substr(3, nchar(.) - 1) %>%
+        paste0("[", ., "]") %>%
+        as.name()
+
+      return(name)
+    }
+
+    new_call
+  }
+
+  lambda <- paste0("(object, {index, data}) => ")
+
+  if (is.name(expr)) {
+    return(
+      htmlwidgets::JS(
+        paste0(lambda, deparse(visit_name(expr), backtick = FALSE))
+      )
+    )
+  }
+
+  # get rhs of formula
+  formula <- expr[[length(expr)]]
+  htmlwidgets::JS(
+    paste0(lambda, deparse(visit_call(formula), backtick = FALSE))
+  )
+}

R/add_arc_layer.R

@@ -0,0 +1,89 @@
+#' Add ArcLayer to an rdeck map.
+#'
+#' @name add_arc_layer
+#' @param rdeck \`{rdeck}\` an rdeck widget instance
+#' @param data `{data.frame | sf}`
+#' @param visible `{logical}`
+#' @param pickable `{logical}`
+#' @param opacity `{numeric}`
+#' @param position_format `{"XY" | "XYZ"}`
+#' @param color_format `{"RGB" | "RGBA"}`
+#' @param auto_highlight `{logical}`
+#' @param highlight_color `{integer}`
+#' @param get_source_position `{accessor | JS}`
+#' @param get_target_position `{accessor | JS}`
+#' @param get_source_color `{accessor}`
+#' @param get_target_color `{accessor}`
+#' @param get_width `{accessor | numeric}`
+#' @param get_height `{accessor | numeric}`
+#' @param get_tilt `{accessor | numeric}`
+#' @param width_units `{"pixels" | "meters"}`
+#' @param width_scale `{numeric}`
+#' @param width_min_pixels `{numeric}`
+#' @param width_max_pixels `{numeric}`
+#' @param ... additional layer parameters to pass to deck.gl
+#' @returns \`{rdeck}\`
+#'
+#' @seealso \url{https://github.com/uber/deck.gl/blob/v8.0.16/docs/layers/arc-layer.md}
+#'
+#' @export
+add_arc_layer <- function(rdeck,
+                          data = NULL,
+                          visible = TRUE,
+                          pickable = FALSE,
+                          opacity = 1,
+                          position_format = "XYZ",
+                          color_format = "RGBA",
+                          auto_highlight = FALSE,
+                          highlight_color = c(0, 0, 128, 128),
+                          get_source_position = NULL,
+                          get_target_position = NULL,
+                          get_source_color = NULL,
+                          get_target_color = NULL,
+                          get_width = NULL,
+                          get_height = NULL,
+                          get_tilt = NULL,
+                          width_units = "pixels",
+                          width_scale = 1,
+                          width_min_pixels = 0,
+                          width_max_pixels = 9007199254740991,
+                          ...) {
+  stopifnot(inherits(rdeck, "rdeck"))
+
+  get_source_position <- accessor(data, substitute(get_source_position))
+  get_target_position <- accessor(data, substitute(get_target_position))
+  get_source_color <- accessor(data, substitute(get_source_color))
+  get_target_color <- accessor(data, substitute(get_target_color))
+  get_width <- accessor(data, substitute(get_width))
+  get_height <- accessor(data, substitute(get_height))
+  get_tilt <- accessor(data, substitute(get_tilt))
+
+  params <- c(
+    list(
+      type = "ArcLayer",
+      data = data,
+      visible = visible,
+      pickable = pickable,
+      opacity = opacity,
+      position_format = position_format,
+      color_format = color_format,
+      auto_highlight = auto_highlight,
+      highlight_color = highlight_color,
+      get_source_position = get_source_position,
+      get_target_position = get_target_position,
+      get_source_color = get_source_color,
+      get_target_color = get_target_color,
+      get_width = get_width,
+      get_height = get_height,
+      get_tilt = get_tilt,
+      width_units = width_units,
+      width_scale = width_scale,
+      width_min_pixels = width_min_pixels,
+      width_max_pixels = width_max_pixels
+    ),
+    list(...)
+  )
+
+  do.call(layer, params) %>%
+    add_layer(rdeck, .)
+}

R/add_bitmap_layer.R

@@ -0,0 +1,65 @@
+#' Add BitmapLayer to an rdeck map.
+#'
+#' @name add_bitmap_layer
+#' @param rdeck \`{rdeck}\` an rdeck widget instance
+#' @param data `{data.frame | sf}`
+#' @param visible `{logical}`
+#' @param pickable `{logical}`
+#' @param opacity `{numeric}`
+#' @param position_format `{"XY" | "XYZ"}`
+#' @param color_format `{"RGB" | "RGBA"}`
+#' @param auto_highlight `{logical}`
+#' @param highlight_color `{integer}`
+#' @param image `{"image" | "character"}`
+#' @param bounds `{numeric}`
+#' @param desaturate `{numeric}`
+#' @param transparent_color `{integer}`
+#' @param tint_color `{integer}`
+#' @param ... additional layer parameters to pass to deck.gl
+#' @returns \`{rdeck}\`
+#'
+#' @seealso \url{https://github.com/uber/deck.gl/blob/v8.0.16/docs/layers/bitmap-layer.md}
+#'
+#' @export
+add_bitmap_layer <- function(rdeck,
+                             data = NULL,
+                             visible = TRUE,
+                             pickable = FALSE,
+                             opacity = 1,
+                             position_format = "XYZ",
+                             color_format = "RGBA",
+                             auto_highlight = FALSE,
+                             highlight_color = c(0, 0, 128, 128),
+                             image = NULL,
+                             bounds = c(1, 0, 0, 1),
+                             desaturate = 0,
+                             transparent_color = c(0, 0, 0, 0),
+                             tint_color = c(255, 255, 255),
+                             ...) {
+  stopifnot(inherits(rdeck, "rdeck"))
+
+
+
+  params <- c(
+    list(
+      type = "BitmapLayer",
+      data = data,
+      visible = visible,
+      pickable = pickable,
+      opacity = opacity,
+      position_format = position_format,
+      color_format = color_format,
+      auto_highlight = auto_highlight,
+      highlight_color = highlight_color,
+      image = image,
+      bounds = bounds,
+      desaturate = desaturate,
+      transparent_color = transparent_color,
+      tint_color = tint_color
+    ),
+    list(...)
+  )
+
+  do.call(layer, params) %>%
+    add_layer(rdeck, .)
+}