Merge pull request #886 from ropensci/feature/sf

add support for geom_sf()

Author: cpsievert

.github/ISSUE_TEMPLATE.md

@@ -1,9 +1,13 @@
-Thanks for your interest in plotly!
+Please briefly describe your problem and what output you expect. If you have a question, please don't use this form, but instead ask on the community forum <http://community.plot.ly/c/api/r> or stackoverflow <http://stackoverflow.com>.
 
-Before opening an issue, please search for existing and closed issues. If your problem or idea is not addressed yet, [please open a new issue](https://github.com/ropensci/plotly/issues/new).
+Please include a minimal reprex. The goal of a reprex is to make it as easy as possible for me to recreate your problem so that I can fix it. If you've never heard of a reprex before, start by reading <https://github.com/jennybc/reprex#what-is-a-reprex>, and follow the advice further down the page. Do NOT include session info unless it's explicitly asked for, or you've used `reprex::reprex(..., si = TRUE)` to hide it away.  
 
-Bug reports must be accompanied with a [reproducible example](http://stackoverflow.com/questions/5963269/how-to-make-a-great-r-reproducible-example).
+Delete these instructions once you have read them.
 
-Note that GitHub issues are reserved for bug reports and feature requests only. Implementation questions should be asked on community.plot.ly (tagged [`R`](http://community.plot.ly/c/api/r)) or on Stack Overflow (tagged [`plotly`](https://stackoverflow.com/questions/tagged/plotly)).
+---
 
-Comments on GitHub issues or pull requests should add content to the discussions. Approbation comments such as *+1* or *I would like this feature to be implemented as well* will be deleted by the maintainers. Please use [GitHub reactions](https://github.com/blog/2119-add-reactions-to-pull-requests-issues-and-comments) instead.
+Brief description of the problem
+
+```r
+# insert reprex here
+```

.travis.yml

@@ -40,7 +40,6 @@ before_script:
   - echo "Sys.setenv('plotly_username' = 'cpsievert')" > ~/.Rprofile
   - git clone https://github.com/cpsievert/plotly-test-table.git ../plotly-test-table
   - cd ..; rm -f *.tar.gz; R CMD build $R_PKG
-  - R CMD INSTALL ${R_PKG}_*.tar.gz
 
 script:
   # run R CMD check on the non-pull request build

DESCRIPTION

@@ -60,6 +60,7 @@ Suggests:
     webshot,
     listviewer,
     dendextend,
+    sf,
     RSelenium,
     png,
     IRdisplay

NAMESPACE

@@ -20,6 +20,24 @@ 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)
@@ -67,6 +85,7 @@ S3method(to_basic,GeomRect)
 S3method(to_basic,GeomRibbon)
 S3method(to_basic,GeomRug)
 S3method(to_basic,GeomSegment)
+S3method(to_basic,GeomSf)
 S3method(to_basic,GeomSmooth)
 S3method(to_basic,GeomSpoke)
 S3method(to_basic,GeomStep)
@@ -126,6 +145,9 @@ export(filter)
 export(filter_)
 export(geom2trace)
 export(get_figure)
+export(get_l)
+export(get_x)
+export(get_y)
 export(gg2list)
 export(ggplotly)
 export(group_by)

R/ggplotly.R

@@ -483,10 +483,10 @@ gg2list <- function(p, width = NULL, height = NULL,
   layout$layout$xanchor <- paste0("y", sub("^1$", "", layout$layout$xanchor))
   layout$layout$yanchor <- paste0("x", sub("^1$", "", layout$layout$yanchor))
   # for some layers2traces computations, we need the range of each panel
-  layout$layout$x_min <- sapply(layout$panel_params, function(z) min(z$x.range))
-  layout$layout$x_max <- sapply(layout$panel_params, function(z) max(z$x.range))
-  layout$layout$y_min <- sapply(layout$panel_params, function(z) min(z$y.range))
-  layout$layout$y_max <- sapply(layout$panel_params, function(z) max(z$y.range))
+  layout$layout$x_min <- sapply(layout$panel_params, function(z) min(z$x.range %||% z$x_range))
+  layout$layout$x_max <- sapply(layout$panel_params, function(z) max(z$x.range %||% z$x_range))
+  layout$layout$y_min <- sapply(layout$panel_params, function(z) min(z$y.range %||% z$y_range))
+  layout$layout$y_max <- sapply(layout$panel_params, function(z) max(z$y.range %||% z$y_range))
 
   # layers -> plotly.js traces
   plot$tooltip <- tooltip
@@ -496,7 +496,7 @@ gg2list <- function(p, width = NULL, height = NULL,
 
   # reattach crosstalk key-set attribute
   data <- Map(function(x, y) structure(x, set = y), data, sets)
-  traces <- layers2traces(data, prestats_data, layout$layout, plot)
+  traces <- layers2traces(data, prestats_data, layout, plot)
 
   gglayout <- layers2layout(gglayout, layers, layout$layout)
 
@@ -584,6 +584,60 @@ gg2list <- function(p, width = NULL, height = NULL,
       axisName <- lay[, paste0(xy, "axis")]
       anchor <- lay[, paste0(xy, "anchor")]
       rng <- layout$panel_params[[i]]
+      
+      # panel_params is quite different for "CoordSf"
+      if ("CoordSf" %in% class(p$coordinates)) {
+        # see CoordSf$render_axis_v
+        direction <- if (xy == "x") "E" else "N"
+        idx <- rng$graticule$type == direction & !is.na(rng$graticule$degree_label)
+        tickData <- rng$graticule[idx, ]
+        # TODO: how to convert a language object to unicode character string?
+        rng[[paste0(xy, ".labels")]] <- as.character(tickData[["degree_label"]])
+        rng[[paste0(xy, ".major")]] <- tickData[[paste0(xy, "_start")]]
+        
+        # If it doesn't already exist (for this panel), 
+        # generate graticule (as done in, CoordSf$render_bg)
+        isGrill <- vapply(traces, function(tr) {
+          identical(tr$xaxis, lay$xaxis) && 
+            identical(tr$yaxis, lay$yaxis) &&
+            isTRUE(tr$`_isGraticule`)
+        }, logical(1))
+        
+        if (sum(isGrill) == 0) {
+          d <- expand(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(
+            colour = theme$panel.grid.major$colour,
+            size = theme$panel.grid.major$size,
+            linetype = theme$panel.grid.major$linetype
+          )
+          grill <- geom2trace.GeomPath(d, params)
+          grill$hoverinfo <- "none"
+          grill$showlegend <- FALSE
+          grill$`_isGraticule` <- TRUE
+          grill$xaxis <- lay$xaxis
+          grill$yaxis <- lay$yaxis
+          
+          traces <- c(list(grill), traces)
+        }
+        
+        # if labels are empty, don't show axis ticks
+        emptyTicks <- all(with(
+          rng$graticule, sapply(degree_label, is.na) | sapply(degree_label, nchar) == 0
+        ))
+        if (emptyTicks) {
+          theme$axis.ticks.length <- 0
+        } else{
+          # convert the special *degree expression in plotmath to HTML entity
+          # TODO: can this be done more generally for all ?
+          rng[[paste0(xy, ".labels")]] <- sub(
+            "\\*\\s+degree\\s+\\*", "&#176;", rng[[paste0(xy, ".labels")]]
+          )
+        }
+        
+      }
+      
       # stuff like layout$panel_params is already flipped, but scales aren't
       sc <- if (inherits(plot$coordinates, "CoordFlip")) {
         scales$get_scales(setdiff(c("x", "y"), xy))
@@ -615,7 +669,7 @@ gg2list <- function(p, width = NULL, height = NULL,
         # TODO: log type?
         type = if (isDateType) "date" else if (isDiscreteType) "category" else "linear",
         autorange = isDynamic,
-        range = rng[[paste0(xy, ".range")]],
+        range = rng[[paste0(xy, ".range")]] %||% rng[[paste0(xy, "_range")]],
         tickmode = if (isDynamic) "auto" else "array",
         ticktext = rng[[paste0(xy, ".labels")]],
         tickvals = rng[[paste0(xy, ".major")]],
@@ -632,7 +686,8 @@ gg2list <- function(p, width = NULL, height = NULL,
         showline = !is_blank(axisLine),
         linecolor = toRGB(axisLine$colour),
         linewidth = unitConvert(axisLine, "pixels", type),
-        showgrid = !is_blank(panelGrid),
+        # TODO: always `showgrid=FALSE` and implement our own using traces
+        showgrid = !is_blank(panelGrid) && !"CoordSf" %in% class(p$coordinates),
         domain = sort(as.numeric(doms[i, paste0(xy, c("start", "end"))])),
         gridcolor = toRGB(panelGrid$colour),
         gridwidth = unitConvert(panelGrid, "pixels", type),
@@ -642,6 +697,13 @@ gg2list <- function(p, width = NULL, height = NULL,
         titlefont = text2font(axisTitle)
       )
 
+      # set scaleanchor/scaleratio if these are fixed coordinates
+      fixed_coords <- c("CoordSf", "CoordFixed", "CoordMap", "CoordQuickmap")
+      if (inherits(p$coordinates, fixed_coords) && xy == "y") {
+        axisObj$scaleanchor <- anchor
+        axisObj$scaleratio <- p$coordinates$ratio
+      }
+      
       # tickvals are currently on 0-1 scale, but we want them on data scale
       axisObj$tickvals <- scales::rescale(
         axisObj$tickvals, to = axisObj$range, from = c(0, 1)
@@ -656,8 +718,6 @@ gg2list <- function(p, width = NULL, height = NULL,
         }
       }
 
-      
-      
       if (isDateType) {
         axisObj$range <- invert_date(axisObj$range, sc)
         traces <- lapply(traces, function(tr) {
@@ -785,6 +845,7 @@ gg2list <- function(p, width = NULL, height = NULL,
     }
   } # end of panel loop
 
+  
   # ------------------------------------------------------------------------
   # guide conversion
   #   Strategy: Obtain and translate the output of ggplot2:::guides_train().

R/layers2traces.R

@@ -9,6 +9,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
       y[["geom_params"]], y[["stat_params"]], y[["aes_params"]], 
       position = ggtype(y, "position")
     )
+    
     # by default, show all user-specified and generated aesthetics in hovertext
     stat_aes <- y$stat$default_aes
     map <- c(y$mapping, stat_aes[grepl("^\\.\\.", as.character(stat_aes))])
@@ -27,6 +28,10 @@ layers2traces <- function(data, prestats_data, layout, p) {
     if (identical("fills", hover_on(x))) {
       map <- map[!names(map) %in% c("x", "xmin", "xmax", "y", "ymin", "ymax")]
     }
+    # disregard geometry mapping in hovertext for GeomSf
+    if ("GeomSf" %in% class(y$geom)) {
+      map <- map[!names(map) %in% "geometry"]
+    }
     param[["hoverTextAes"]] <- map
     param
   }, data, p$layers)
@@ -132,8 +137,8 @@ layers2traces <- function(data, prestats_data, layout, p) {
     # each trace is with respect to which axis?
     for (j in seq_along(trs)) {
       panel <- unique(dl[[j]]$PANEL)
-      trs[[j]]$xaxis <-  sub("axis", "", layout[panel, "xaxis"])
-      trs[[j]]$yaxis <-  sub("axis", "", layout[panel, "yaxis"])
+      trs[[j]]$xaxis <-  sub("axis", "", layout$layout[panel, "xaxis"])
+      trs[[j]]$yaxis <-  sub("axis", "", layout$layout[panel, "yaxis"])
     }
     trace.list <- c(trace.list, trs)
   }
@@ -261,6 +266,32 @@ to_basic.GeomRect <- function(data, prestats_data, layout, params, p, ...) {
   prefix_class(dat, c("GeomPolygon", "GeomRect"))
 }
 
+#' @export 
+to_basic.GeomSf <- function(data, prestats_data, layout, params, p, ...) {
+  
+  data <- expand(data)
+  
+  # determine the type of simple feature for each row
+  # recode the simple feature with the type of geometry used to render it
+  data[[".plotlySfType"]] <- sapply(data$geometry, function(x) class(x)[2])
+  dat <- dplyr::mutate(
+    data, .plotlySfType = dplyr::recode(.plotlySfType,
+      MULTIPOLYGON = "GeomPolygon",
+      MULTILINESTRING = "GeomLine",
+      MULTIPOINT = "GeomPoint",
+      POLYGON = "GeomPolygon",
+      LINESTRING = "GeomLine",
+      POINT = "GeomPoint"
+  ))
+  
+  # return a list of data frames...one for every geometry (a la, GeomSmooth)
+  d <- split(dat, dat[[".plotlySfType"]])
+  for (i in seq_along(d)) {
+    d[[i]] <- prefix_class(d[[i]], names(d)[[i]])
+  }
+  if (length(d) == 1) d[[1]] else d
+}
+
 #' @export
 to_basic.GeomMap <- function(data, prestats_data, layout, params, p, ...) {
   common <- intersect(data$map_id, params$map$id)
@@ -354,7 +385,7 @@ to_basic.GeomAbline <- function(data, prestats_data, layout, params, p, ...) {
   data$group <- interaction(
     data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
   )
-  lay <- tidyr::gather_(layout, "variable", "x", c("x_min", "x_max"))
+  lay <- tidyr::gather_(layout$layout, "variable", "x", c("x_min", "x_max"))
   data <- merge(lay[c("PANEL", "x")], data, by = "PANEL")
   data[["y"]] <- with(data, intercept + slope * x)
   prefix_class(data, c("GeomHline", "GeomPath"))
@@ -366,7 +397,7 @@ to_basic.GeomHline <- function(data, prestats_data, layout, params, p, ...) {
   data$group <- do.call(paste,
     data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
   )
-  lay <- tidyr::gather_(layout, "variable", "x", c("x_min", "x_max"))
+  lay <- tidyr::gather_(layout$layout, "variable", "x", c("x_min", "x_max"))
   data <- merge(lay[c("PANEL", "x")], data, by = "PANEL")
   data[["y"]] <- data$yintercept
   prefix_class(data, c("GeomHline", "GeomPath"))
@@ -378,7 +409,7 @@ to_basic.GeomVline <- function(data, prestats_data, layout, params, p, ...) {
   data$group <- do.call(paste,
     data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
   )
-  lay <- tidyr::gather_(layout, "variable", "y", c("y_min", "y_max"))
+  lay <- tidyr::gather_(layout$layout, "variable", "y", c("y_min", "y_max"))
   data <- merge(lay[c("PANEL", "y")], data, by = "PANEL")
   data[["x"]] <- data$xintercept
   prefix_class(data, c("GeomVline", "GeomPath"))
@@ -394,7 +425,7 @@ to_basic.GeomJitter <- function(data, prestats_data, layout, params, p, ...) {
 to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, p, ...) {
   # width for ggplot2 means size of the entire bar, on the data scale
   # (plotly.js wants half, in pixels)
-  data <- merge(data, layout, by = "PANEL", sort = FALSE)
+  data <- merge(data, layout$layout, by = "PANEL", sort = FALSE)
   data$width <- (data[["xmax"]] - data[["x"]]) /(data[["x_max"]] - data[["x_min"]])
   data$fill <- NULL
   prefix_class(data, "GeomErrorbar")
@@ -404,7 +435,7 @@ to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, p, ...) {
 to_basic.GeomErrorbarh <- function(data, prestats_data, layout, params, p, ...) {
   # height for ggplot2 means size of the entire bar, on the data scale
   # (plotly.js wants half, in pixels)
-  data <- merge(data, layout, by = "PANEL", sort = FALSE)
+  data <- merge(data, layout$layout, by = "PANEL", sort = FALSE)
   data$width <- (data[["ymax"]] - data[["y"]]) / (data[["y_max"]] - data[["y_min"]])
   data$fill <- NULL
   prefix_class(data, "GeomErrorbarh")
@@ -443,11 +474,11 @@ to_basic.GeomPointrange <- function(data, prestats_data, layout, params, p, ...)
 #' @export
 to_basic.GeomDotplot <- function(data, prestats_data, layout, params, p, ...) {
   if (identical(params$binaxis, "y")) {
-    dotdia <- params$dotsize * data$binwidth[1]/(layout$y_max - layout$y_min)
+    dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$y_max - layout$layout$y_min)
     data$size <- as.numeric(grid::convertHeight(grid::unit(dotdia, "npc"), "mm")) / 2
     data$x <- (data$countidx - 0.5) * (as.numeric(dotdia) * 6)
   } else {
-    dotdia <- params$dotsize * data$binwidth[1]/(layout$x_max - layout$x_min)
+    dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$x_max - layout$layout$x_min)
     data$size <- as.numeric(grid::convertWidth(grid::unit(dotdia, "npc"), "mm")) / 2
     # TODO: why times 6?!?!
     data$y <- (data$countidx - 0.5) * (as.numeric(dotdia) * 6)
@@ -482,6 +513,7 @@ utils::globalVariables(c("xmin", "xmax", "y", "size"))
 #' @export
 to_basic.GeomRug  <- function(data, prestats_data, layout, params, p, ...) {
   # allow the tick length to vary across panels
+  layout <- layout$layout
   layout$tickval_y <- 0.03 * abs(layout$y_max - layout$y_min)
   layout$tickval_x <- 0.03 * abs(layout$x_max - layout$x_min)
   data <- merge(data, layout[c("PANEL", "x_min", "x_max", "y_min", "y_max", "tickval_y", "tickval_x")])
@@ -687,7 +719,9 @@ geom2trace.GeomBar <- function(data, params, p) {
 
 #' @export
 geom2trace.GeomPolygon <- function(data, params, p) {
+  
   data <- group2NA(data)
+  
   L <- list(
     x = data[["x"]],
     y = data[["y"]],