fortify sf objects in a similar manner to sf::st_as_grob

Author: cpsievert

NAMESPACE

@@ -20,24 +20,6 @@ S3method(geom2trace,GeomPolygon)
 S3method(geom2trace,GeomText)
 S3method(geom2trace,GeomTile)
 S3method(geom2trace,default)
-S3method(get_l,LINESTRING)
-S3method(get_l,MULTILINESTRING)
-S3method(get_l,MULTIPOINT)
-S3method(get_l,MULTIPOLYGON)
-S3method(get_l,POINT)
-S3method(get_l,POLYGON)
-S3method(get_x,LINESTRING)
-S3method(get_x,MULTILINESTRING)
-S3method(get_x,MULTIPOINT)
-S3method(get_x,MULTIPOLYGON)
-S3method(get_x,POINT)
-S3method(get_x,POLYGON)
-S3method(get_y,LINESTRING)
-S3method(get_y,MULTILINESTRING)
-S3method(get_y,MULTIPOINT)
-S3method(get_y,MULTIPOLYGON)
-S3method(get_y,POINT)
-S3method(get_y,POLYGON)
 S3method(ggplot,plotly)
 S3method(ggplotly,ggmatrix)
 S3method(ggplotly,ggplot)
@@ -58,6 +40,17 @@ S3method(print,api_plot)
 S3method(rename_,plotly)
 S3method(select_,plotly)
 S3method(slice_,plotly)
+S3method(st_as_plotly,CIRCULARSTRING)
+S3method(st_as_plotly,COMPOUNDCURVE)
+S3method(st_as_plotly,CURVEPOLYGON)
+S3method(st_as_plotly,GEOMETRYCOLLECTION)
+S3method(st_as_plotly,LINESTRING)
+S3method(st_as_plotly,MULTILINESTRING)
+S3method(st_as_plotly,MULTIPOINT)
+S3method(st_as_plotly,MULTIPOLYGON)
+S3method(st_as_plotly,MULTISURFACE)
+S3method(st_as_plotly,POINT)
+S3method(st_as_plotly,POLYGON)
 S3method(summarise_,plotly)
 S3method(to_basic,GeomAbline)
 S3method(to_basic,GeomAnnotationMap)
@@ -145,9 +138,6 @@ export(filter)
 export(filter_)
 export(geom2trace)
 export(get_figure)
-export(get_l)
-export(get_x)
-export(get_y)
 export(gg2list)
 export(ggplotly)
 export(group2NA)

R/ggplotly.R

@@ -621,7 +621,7 @@ gg2list <- function(p, width = NULL, height = NULL,
 
         if (sum(isGrill) == 0) {
           # TODO: reduce the number of points (via coord_munch?)
-          d <- expand(rng$graticule)
+          d <- sf_fortify(rng$graticule)
           d$x <- scales::rescale(d$x, rng$x_range, from = c(0, 1))
           d$y <- scales::rescale(d$y, rng$y_range, from = c(0, 1))
           params <- list(

R/group2NA.R

@@ -45,6 +45,12 @@ group2NA <- function(data, groupNames = "group", nested = NULL, ordered = NULL,
 
   if (NROW(data) == 0) return(data)
 
+  # for restoring class information on exit
+  datClass <- oldClass(data)
+  
+  # data.table doesn't play nice with list-columns
+  if (inherits(data, "sf") || inherits(data, "GeomSf")) data <- sf_fortify(data)
+  
   # evaluate this lazy argument now (in case we change class of data)
   retrace <- force(retrace.first)
 
@@ -53,9 +59,6 @@ group2NA <- function(data, groupNames = "group", nested = NULL, ordered = NULL,
   nested <- nested[nested %in% names(data)]
   ordered <- ordered[ordered %in% names(data)]
 
-  # for restoring class information on exit
-  datClass <- oldClass(data)
-  
   dt <- data.table::as.data.table(data)
 
   # if group doesn't exist, just order the rows and exit

R/layers2traces.R

@@ -270,31 +270,29 @@ to_basic.GeomRect <- function(data, prestats_data, layout, params, p, ...) {
   prefix_class(dat, c("GeomPolygon", "GeomRect"))
 }
 
-#' @export 
+#' @export
 to_basic.GeomSf <- function(data, prestats_data, layout, params, p, ...) {
 
-  browser()
-  sf_data <- sf::st_as_sf(data)
-  sf_d <- lapply(1:nrow(data), function(i) {
-    sf_as_plotly(sf_data[i, , drop = FALSE])
-  })
-    
-    sf_as_plotly()
-  
-  # logic based on GeomSf$draw_panel
-  #p$coord$transform(data, layout$panel_params[[1]])
-  
-  geomBasic <- switch(
-    params$legend %||% "", 
-    point = "GeomPoint", 
-    line = "GeomPath", 
-    "GeomPolygon"
+  # map sf geometry types to a suitable "basic geom"
+  # TODO: support more of the esoteric geometry types, see sf::st_geometry_type
+  # most important is probable geometry collection
+  geom_type <- sf::st_geometry_type(sf::st_as_sf(data))
+  basic_type <- dplyr::recode(
+    as.character(geom_type),
+    MULTIPOLYGON = "GeomPolygon",
+    MULTILINESTRING = "GeomPath",
+    MULTIPOINT = "GeomPoint",
+    POLYGON = "GeomPolygon",
+    LINESTRING = "GeomPath",
+    POINT = "GeomPoint"
   )
 
-  
-  # determine the type of simple feature for each row
-  # recode the simple feature with the type of geometry used to render it
-  prefix_class(data, c("GeomSf", geomBasic))
+  # return a list of data frames...one for every geometry (a la, GeomSmooth)
+  d <- split(data, basic_type)
+  for (i in seq_along(d)) {
+    d[[i]] <- prefix_class(d[[i]], names(d)[[i]])
+  }
+  if (length(d) == 1) d[[1]] else d
 }
 
 #' @export
@@ -724,7 +722,7 @@ geom2trace.GeomBar <- function(data, params, p) {
 
 #' @export
 geom2trace.GeomPolygon <- function(data, params, p) {
-  
+
   data <- group2NA(data)
 
   L <- list(
@@ -913,7 +911,7 @@ split_on <- function(dat) {
 
 # given a geom, are we hovering over points or fill?
 hover_on <- function(data) {
-  if (inherits(data, c("GeomHex", "GeomRect", "GeomMap", "GeomMosaic", "GeomAnnotationMap")) ||
+  if (inherits(data, c("GeomHex", "GeomRect", "GeomMap", "GeomMosaic", "GeomAnnotationMap", "GeomSf")) ||
       # is this a "basic" polygon?
       identical("GeomPolygon", grep("^Geom", class(data), value = T))) {
     "fills"
@@ -973,7 +971,7 @@ aes2plotly <- function(data, params, aes = "size") {
 
   # Hack to support this geom_sf hack 
   # https://github.com/tidyverse/ggplot2/blob/505e4bfb/R/sf.R#L179-L187
-  defaults <- if (identical(geom, "GeomSf")) {
+  defaults <- if (inherits(data, "GeomSf")) {
     type <- if (any(grepl("point", class(data)))) "point" else if (any(grepl("line", class(data)))) "line" else ""
     ggfun("default_aesthetics")(type)
   } else {

R/sf.R

@@ -1,84 +1,90 @@
-# kind of like sf_as_plotly(), but maps to a plotly data structure, rather than a grob
-sf_as_plotly <- function(row, ...) {
+sf_fortify <- function(model, ...) {
+  # TODO: 
+  # (1) avoid converting redundant features
+  # (2) warn/error if data already contains x/y 
+  geoms <- sf::st_geometry(sf::st_as_sf(model))
+  xy <- lapply(geoms, st_as_plotly)
+  ids <- rep(seq_len(nrow(model)), sapply(xy, nrow))
+  xy_all <- cbind(do.call(rbind, xy), ids)
+  sf_key_name <- ".sf-group-id"
+  xy_dat <- setNames(as.data.frame(xy_all), c("x", "y", sf_key_name))
+  
+  d <- as.data.frame(model)
+  d$geometry <- NULL
+  d[[sf_key_name]] <- seq_len(nrow(d))
+  xy_dat <- dplyr::left_join(xy_dat, d, by = sf_key_name)
+  xy_dat[[sf_key_name]] <- NULL
+  xy_dat
+}
+
+# kind of like sf_as_grob(), but maps to a plotly data structure, rather than a grob
+st_as_plotly <- function(x, ...) {
   UseMethod("st_as_plotly")
 }
 
 #' @export
-sf_as_plotly.POINT = function(row, ...) {
-  x <- row[1] 
-  y <- row[2]
-  x
+st_as_plotly.POINT = function(x, ...) {
+  matrix(c(x[1], x[2]), ncol = 2)
 }
 
 #' @export
-sf_as_plotly.MULTIPOINT = function(row, ...) {
-  if (nrow(x) == 0)
-    nullGrob()
-  else
-    pointsGrob(x[,1], x[,2], ..., default.units = default.units)
+st_as_plotly.MULTIPOINT = function(x, ...) {
+  if (nrow(x) == 0) return(empty_xy())
+  matrix(c(x[, 1], x[, 2]), ncol = 2)
 }
 
 #' @export
-sf_as_plotly.LINESTRING = function(row, ...) {
-  if (nrow(x) == 0)
-    nullGrob()
-  else
-    linesGrob(x[,1], x[,2], ..., default.units = default.units)
+st_as_plotly.LINESTRING = function(x, ...) {
+  if (nrow(x) == 0) return(empty_xy())
+  matrix(c(x[, 1], x[, 2]), ncol = 2)
 }
 
 #' @export
-sf_as_plotly.CIRCULARSTRING = function(x, y, ...) {
-  sf_as_plotly(st_cast(x, "LINESTRING"),  ...)
+st_as_plotly.CIRCULARSTRING = function(x, y, ...) {
+  st_as_plotly(st_cast(x, "LINESTRING"),  ...)
 }
 
 #' @export
-sf_as_plotly.MULTILINESTRING = function(row, ...) {
-  if (length(x) == 0)
-    nullGrob()
-  else {
-    get_x = function(x) unlist(sapply(x, function(y) y[,1]))
-    get_y = function(x) unlist(sapply(x, function(y) y[,2]))
-    polylineGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), ...,
-                 default.units = default.units)
-  }
+st_as_plotly.MULTILINESTRING = function(x, ...) {
+  if (length(x) == 0) return(empty_xy())
+  xvals <- unlist(rbind(sapply(x, function(y) y[,1]), NA))
+  yvals <- unlist(rbind(sapply(x, function(y) y[,2]), NA))
+  matrix(c(xvals, yvals), ncol = 2)
 }
 
 #' @export
-sf_as_plotly.POLYGON = function(row, ..., rule = "evenodd") {
-  if (length(x) == 0)
-    nullGrob()
-  else {
-    get_x = function(x) unlist(sapply(x, function(y) y[,1]))
-    get_y = function(x) unlist(sapply(x, function(y) y[,2]))
-    pathGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), ..., default.units = default.units, rule = rule)
-  }
+st_as_plotly.POLYGON = function(x, ..., rule = "evenodd") {
+  if (length(x) == 0) return(empty_xy())
+  xvals <- unlist(rbind(sapply(x, function(y) y[,1]), NA))
+  yvals <- unlist(rbind(sapply(x, function(y) y[,2]), NA))
+  matrix(c(xvals, yvals), ncol = 2)
 }
 
 #' @export
-sf_as_plotly.MULTIPOLYGON = function(row, ..., rule = "evenodd") {
-  if (length(x) == 0)
-    nullGrob()
-  else {
-    get_x = function(x) unlist(sapply(x, function(y) sapply(y, function(z) z[,1])))
-    get_y = function(x) unlist(sapply(x, function(y) sapply(y, function(z) z[,2])))
-    get_l = function(x) unlist(sapply(x, function(y) vapply(y, nrow, 0L)))
-    pathGrob(get_x(x), get_y(x), id.lengths = get_l(x), ..., default.units = default.units, rule = rule)
-  }
+st_as_plotly.MULTIPOLYGON = function(x, ..., rule = "evenodd") {
+  if (length(x) == 0) return(empty_xy())
+  xvals <- unlist(sapply(x, function(y) rbind(sapply(y, function(z) z[,1]), NA)))
+  yvals <- unlist(sapply(x, function(y) rbind(sapply(y, function(z) z[,2]), NA)))
+  matrix(c(xvals, yvals), ncol = 2)
 }
 
 #' @export
-sf_as_plotly.GEOMETRYCOLLECTION = function(row, ...) {
-  if (length(x) == 0)
-    nullGrob()
-  else
-    do.call(grid::grobTree, lapply(x, sf_as_plotly, ..., default.units = default.units))
+st_as_plotly.GEOMETRYCOLLECTION = function(x, ...) {
+  if (length(x) == 0) return(empty_xy())
+  lapply(x, st_as_plotly)
 }
 
 #' @export
-sf_as_plotly.MULTISURFACE = sf_as_plotly.GEOMETRYCOLLECTION
+st_as_plotly.MULTISURFACE = st_as_plotly.GEOMETRYCOLLECTION
 
 #' @export
-sf_as_plotly.CURVEPOLYGON = sf_as_plotly.GEOMETRYCOLLECTION
+st_as_plotly.CURVEPOLYGON = st_as_plotly.GEOMETRYCOLLECTION
 
 #' @export
-sf_as_plotly.COMPOUNDCURVE = sf_as_plotly.GEOMETRYCOLLECTION
+st_as_plotly.COMPOUNDCURVE = st_as_plotly.GEOMETRYCOLLECTION
+
+
+
+empty_xy <- function() {
+  matrix(rep(NA, 2), ncol = 2)
+}