route sf::st_bbox to geo's lataxis.range/lonaxis.range

Author: cpsievert

R/utils.R

@@ -210,6 +210,8 @@ mapbox_token <- function() {
 }
 
 mapbox_fit_bounds <- function(p) {
+  # Route trace[i]._bbox info to layout.mapboxid._fitBounds
+  # so that we have a sensible range for each mapbox subplot
   mapboxIDs <- grep("^mapbox", sapply(p$x$data, "[[", "subplot"), value = TRUE)
   for (id in mapboxIDs) {
     bboxes <- lapply(p$x$data, function(tr) if (identical(id, tr$subplot)) tr[["_bbox"]])
@@ -232,6 +234,22 @@ mapbox_fit_bounds <- function(p) {
       )
     )
   }
+  
+  # Route trace[i]._bbox info to layout.geoid.lonaxis/layout.geoid.lataxis
+  geoIDs <- grep("^geo", sapply(p$x$data, "[[", "geo"), value = TRUE)
+  for (id in geoIDs) {
+    bboxes <- lapply(p$x$data, function(tr) if (identical(id, tr$geo)) tr[["_bbox"]])
+    if (sum(lengths(bboxes)) == 0) next
+    p$x$layout[[id]]$lataxis$range <- grDevices::extendrange(c(
+      min(unlist(lapply(bboxes, "[[", "ymin")), na.rm = TRUE),
+      max(unlist(lapply(bboxes, "[[", "ymax")), na.rm = TRUE)
+    ), f = 0.01)
+    p$x$layout[[id]]$lonaxis$range <- grDevices::extendrange(c(
+      min(unlist(lapply(bboxes, "[[", "xmin")), na.rm = TRUE),
+      max(unlist(lapply(bboxes, "[[", "xmax")), na.rm = TRUE)
+    ), f = 0.01)
+  }
+  
   p
 }
 

demo/00Index

@@ -12,5 +12,7 @@ crosstalk-filter-lines              Using crosstalk's filter_select() to filter
 crosstalk-filter-dynamic-axis       Using crosstalk's filter_select() to dynamically change the y-axis
 rotate                              Using htmlwidgets::onRender() to rotate the camera of a 3D graph
 ternary                             A basic ternary plot
-sf-data-scattermapbox               Mapping sf objects with mapbox
-sf-layout-scattermapbox             Mapping sf objects with mapbox (as a layer) 
+sf-mapbox-data                      Mapping sf objects with mapbox
+sf-mapbox-layout                    Mapping sf objects with mapbox (as a layer) 
+sf-ggplot2                          Mapping sf objects via ggplot2 and geom_sf()
+sf-geo                              Mapping sf objects with scattergeo

demo/sf-data-scattermapbox.R

@@ -0,0 +1,12 @@
+library(sf)
+library(plotly)
+
+nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
+storms <- st_read(system.file("shape/storms_xyz.shp", package = "sf"), quiet = TRUE)
+
+# TODO: geometry should be added as a grouping variable?
+subplot(
+  plot_geo(nc),
+  plot_geo(storms)
+)
+

demo/sf-geo.R

@@ -0,0 +1,30 @@
+library(plotly)
+library(sf)
+
+nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
+p <- ggplot(nc) + geom_sf(aes(fill = AREA))
+ggplotly(p)
+
+# If not supplied, coord_sf() will take the CRS from the first layer
+# and automatically transform all other layers to use that CRS. This
+# ensures that all data will correctly line up
+nc_3857 <- sf::st_transform(nc, "+init=epsg:3857")
+p2 <- ggplot() +
+  geom_sf(data = nc) +
+  geom_sf(data = nc_3857, colour = "red", fill = NA)
+ggplotly(p2)
+
+# Unfortunately if you plot other types of feature you'll need to use
+# show.legend to tell ggplot2 what type of legend to use
+nc_3857$mid <- sf::st_centroid(nc_3857$geometry)
+p3 <- ggplot(nc_3857) +
+  geom_sf(colour = "white") +
+  geom_sf(aes(geometry = mid, size = AREA), show.legend = "point")
+ggplotly(p3)
+
+# You can also use layers with x and y aesthetics: these are
+# assumed to already be in the common CRS.
+p4 <- ggplot(nc) +
+  geom_sf() +
+  annotate("point", x = -80, y = 35, colour = "red", size = 4)
+ggplotly(p4)

demo/sf-ggplot2.R

@@ -0,0 +1,44 @@
+library(sf)
+library(plotly)
+
+nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
+
+# can set multiple bounding boxes and overwrite attributes 
+subplot(
+  plot_mapbox(nc),
+  plot_mapbox(nc, fillcolor = "gray", line = list(size = 0.01, color = "black"))
+)
+
+# can map custom hover text to each point
+plot_mapbox(nc, text = ~AREA, hoverinfo = "text")
+
+# TODO: 
+# (1) this should create multiple traces!!! :(
+# (2) perhaps the colorbar definition needs fixing?
+plot_mapbox(nc, color = ~AREA, text = ~AREA, hoverinfo = "text", hoveron = "fill") %>%
+  plotly_json()
+
+# TODO: animation
+
+
+
+# TODO: perhaps during verification, if hoveron = 'fill' for a given trace,
+# we could check if text is unique or not...if it is, just take first element
+plot_mapbox(nc, split = ~AREA, text = ~NAME, hoveron = "fill")
+
+# TODO: how to best control hoverinfo?
+
+# add dropdown for changing baselayer
+# TODO: how to keep the bounding box fixed?
+styles <- schema(FALSE)$layout$layoutAttributes$mapbox$style$values
+style_buttons <- lapply(styles, function(s) {
+  list(label = s, method = "relayout", args = list("mapbox.style", s))
+})
+
+p1 %>%
+  layout(
+    title = "Changing the base layer",
+    updatemenus = list(list(y = 0.8, buttons = style_buttons))
+  )
+
+