Merge pull request #807 from rhijmans/main

Support for SpatVector and SpatRaster

Author: jcheng5

.github/workflows/R-CMD-check.yaml

@@ -24,3 +24,4 @@ jobs:
     uses: rstudio/shiny-workflows/.github/workflows/R-CMD-check.yaml@v1
     with:
       minimum-r-version: "3.5.0"
+      ubuntu: "ubuntu-20.04"

DESCRIPTION

@@ -61,7 +61,8 @@ Suggests:
     RJSONIO,
     purrr,
     testthat (>= 3.0.0),
-    s2
-RoxygenNote: 7.1.2
+    s2,
+    terra
+RoxygenNote: 7.2.0
 Encoding: UTF-8
 LazyData: true

NAMESPACE

@@ -3,6 +3,7 @@
 S3method("[",leaflet_awesome_icon_set)
 S3method("[",leaflet_icon_set)
 S3method(metaData,SharedData)
+S3method(metaData,SpatVector)
 S3method(metaData,SpatialLinesDataFrame)
 S3method(metaData,SpatialPointsDataFrame)
 S3method(metaData,SpatialPolygonsDataFrame)
@@ -12,6 +13,7 @@ S3method(metaData,map)
 S3method(metaData,sf)
 S3method(pointData,POINT)
 S3method(pointData,SharedData)
+S3method(pointData,SpatVector)
 S3method(pointData,SpatialPoints)
 S3method(pointData,SpatialPointsDataFrame)
 S3method(pointData,data.frame)
@@ -25,6 +27,7 @@ S3method(polygonData,Lines)
 S3method(polygonData,Polygon)
 S3method(polygonData,Polygons)
 S3method(polygonData,SharedData)
+S3method(polygonData,SpatVector)
 S3method(polygonData,SpatialLines)
 S3method(polygonData,SpatialLinesDataFrame)
 S3method(polygonData,SpatialPolygons)

NEWS

@@ -6,6 +6,8 @@ BUG FIXES and IMPROVEMENTS
 
 * New behavior from tile.openstreetmap.org caused `addTiles` default tileset to break when viewed under non-https protocol on recent versions of Chrome. Fixed by always using the https protocol to connect to openstreetmap. (#786)
 
+* Added support for SpatRaster and SpatVector objects from the terra package. (#728)
+
 leaflet 2.1.0
 --------------------------------------------------------------------------------
 

R/layers.R

@@ -172,12 +172,13 @@ addTiles <- function(
 epsg4326 <- "+proj=longlat +datum=WGS84 +no_defs"
 epsg3857 <- "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext +no_defs" # nolint
 
+
 #' Add a raster image as a layer
 #'
-#' Create an image overlay from a \code{RasterLayer} object. \emph{This is only
-#' suitable for small to medium sized rasters}, as the entire image will be
-#' embedded into the HTML page (or passed over the websocket in a Shiny
-#' context).
+#' Create an image overlay from a \code{RasterLayer} or a \code{SpatRaster}
+#' object. \emph{This is only suitable for small to medium sized rasters},
+#' as the entire image will be embedded into the HTML page (or passed over
+#' the websocket in a Shiny context).
 #'
 #' The \code{maxBytes} parameter serves to prevent you from accidentally
 #' embedding an excessively large amount of data into your htmlwidget. This
@@ -187,18 +188,22 @@ epsg3857 <- "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y
 #' aware that very large rasters may not only make your map a large download but
 #' also may cause the browser to become slow or unresponsive.
 #'
-#' By default, the \code{addRasterImage} function will project the RasterLayer
-#' \code{x} to EPSG:3857 using the \code{raster} package's
-#' \code{\link[raster]{projectRaster}} function. This can be a time-consuming
-#' operation for even moderately sized rasters. Upgrading the \code{raster}
-#' package to 2.4 or later will provide a large speedup versus previous
-#' versions. If you are repeatedly adding a particular raster to your Leaflet
+#' To reduce the size of a SpatRaster, you can use \code{\link[terra]{spatSample}}
+#' as in \code{x = spatSample(x, 100000, method="regular", as.raster=TRUE)}. With
+#' a \code{RasterLayer} you can use \code{\link[raster]{sampleRegular}} as in
+#' \code{sampleRegular(x, 100000, asRaster=TRUE)}.
+#'
+#' By default, the \code{addRasterImage} function will project the raster data
+#' \code{x} to the Pseudo-Mercator projection (EPSG:3857). This can be a
+#' time-consuming operation for even moderately sized rasters; although it is much
+#' faster for SpatRasters than for RasterLayers.
+#' If you are repeatedly adding a particular raster to your Leaflet
 #' maps, you can perform the projection ahead of time using
 #' \code{projectRasterForLeaflet()}, and call \code{addRasterImage} with
 #' \code{project = FALSE}.
 #'
 #' @param map a map widget object
-#' @param x a \code{RasterLayer} object--see \code{\link[raster]{raster}}
+#' @param x a \code{\link[terra]{SpatRaster}} or a \code{RasterLayer} object--see \code{\link[raster]{raster}}
 #' @param colors the color palette (see \code{\link{colorNumeric}}) or function
 #'   to use to color the raster values (hint: if providing a function, set
 #'   \code{na.color} to \code{"#00000000"} to make \code{NA} areas transparent)
@@ -235,7 +240,7 @@ epsg3857 <- "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y
 addRasterImage <- function(
   map,
   x,
-  colors = if (raster::is.factor(x)) "Set1" else "Spectral",
+  colors = if (is.factor(x)[1]) "Set1" else "Spectral",
   opacity = 1,
   attribution = NULL,
   layerId = NULL,
@@ -245,7 +250,54 @@ addRasterImage <- function(
   maxBytes = 4 * 1024 * 1024,
   data = getMapData(map)
 ) {
-  stopifnot(inherits(x, "RasterLayer"))
+  if (inherits(x, "SpatRaster")) {
+    addRasterImage_SpatRaster(
+      map=map,
+      x=x,
+      colors = colors,
+      opacity = opacity,
+      attribution = attribution,
+      layerId = layerId,
+      group = group,
+      project = project,
+      method = method,
+      maxBytes = maxBytes,
+      data = data
+    )
+  } else if (inherits(x, "RasterLayer")) {
+    addRasterImage_RasterLayer(
+      map=map,
+      x=x,
+      colors = colors,
+      opacity = opacity,
+      attribution = attribution,
+      layerId = layerId,
+      group = group,
+      project = project,
+      method = method,
+      maxBytes = maxBytes,
+      data = data
+    )
+  } else {
+    stop("Don't know how to get path data from object of class ", class(x)[[1]])
+  }
+}
+
+
+addRasterImage_RasterLayer <- function(
+  map,
+  x,
+  colors = if (is.factor(x)[1]) "Set1" else "Spectral",
+  opacity = 1,
+  attribution = NULL,
+  layerId = NULL,
+  group = NULL,
+  project = TRUE,
+  method = c("auto", "bilinear", "ngb"),
+  maxBytes = 4 * 1024 * 1024,
+  data = getMapData(map)
+) {
+
 
   raster_is_factor <- raster::is.factor(x)
   method <- match.arg(method)
@@ -260,11 +312,6 @@ addRasterImage <- function(
   if (project) {
     # if we should project the data
     projected <- projectRasterForLeaflet(x, method)
-
-    # if data is factor data, make the result factors as well.
-    if (raster_is_factor) {
-      projected <- raster::as.factor(projected)
-    }
   } else {
     # do not project data
     projected <- x
@@ -311,14 +358,116 @@ addRasterImage <- function(
     )
 }
 
+addRasterImage_SpatRaster <- function(
+  map,
+  x,
+  colors = if (terra::is.factor(x)[1]) "Set1" else "Spectral",
+  opacity = 1,
+  attribution = NULL,
+  layerId = NULL,
+  group = NULL,
+  project = TRUE,
+  method = c("auto", "bilinear", "ngb"),
+  maxBytes = 4 * 1024 * 1024,
+  data = getMapData(map)
+) {
+
+  if (terra::nlyr(x) > 1) {
+    x <- x[[1]]
+    warning("using the first layer in 'x'", call. = FALSE)
+  }
+
+  raster_is_factor <- terra::is.factor(x)
+  method <- match.arg(method)
+  if (method == "ngb") method = "near"
+  if (method == "auto") {
+    if (raster_is_factor) {
+      method <- "near"
+    } else {
+      method <- "bilinear"
+    }
+  }
+
+  if (project) {
+    # if we should project the data
+    projected <- projectRasterForLeaflet(x, method)
+  } else {
+    # do not project data
+    projected <- x
+  }
+
+  bounds <- terra::ext(
+    terra::project(
+      terra::project(
+        terra::as.points(terra::ext(x), crs=terra::crs(x)),
+        epsg3857),
+      epsg4326)
+  )
+
+  if (!is.function(colors)) {
+    if (method == "near") {
+      # 'factors'
+      colors <- colorFactor(colors, domain = NULL, na.color = "#00000000", alpha = TRUE)
+    } else {
+      # 'numeric'
+      colors <- colorNumeric(colors, domain = NULL, na.color = "#00000000", alpha = TRUE)
+    }
+  }
+
+  tileData <- terra::values(projected) %>% as.vector() %>% colors() %>% col2rgb(alpha = TRUE) %>% as.raw()
+  dim(tileData) <- c(4, ncol(projected), nrow(projected))
+  pngData <- png::writePNG(tileData)
+  if (length(pngData) > maxBytes) {
+    stop(
+      "Raster image too large; ", length(pngData), " bytes is greater than maximum ",
+      maxBytes, " bytes"
+    )
+  }
+  encoded <- base64enc::base64encode(pngData)
+  uri <- paste0("data:image/png;base64,", encoded)
+
+  latlng <- list(
+    list(terra::ymax(bounds), terra::xmin(bounds)),
+    list(terra::ymin(bounds), terra::xmax(bounds))
+  )
+
+  invokeMethod(map, data, "addRasterImage", uri, latlng, opacity, attribution, layerId, group) %>%
+    expandLimits(
+      c(terra::ymin(bounds), terra::ymax(bounds)),
+      c(terra::xmin(bounds), terra::xmax(bounds))
+    )
+}
+
+
+
 #' @rdname addRasterImage
 #' @export
 projectRasterForLeaflet <- function(x, method) {
-  raster::projectRaster(
-    x,
-    raster::projectExtent(x, crs = sp::CRS(epsg3857)),
-    method = method
-  )
+  if (inherits(x, "SpatRaster")) {
+    if (method=="ngb") {
+      method = "near"
+    }
+    terra::project(
+      x,
+      y=epsg3857,
+      method=method
+    )
+  } else {
+    raster_is_factor <- raster::is.factor(x);
+    projected <- raster::projectRaster(
+      x,
+      raster::projectExtent(x, crs = sp::CRS(epsg3857)),
+      method = method
+    )
+    # if data is factor data, make the result factors as well.
+    # only meaningful if ngb was used
+    if ((raster_is_factor) && (method == "ngb")) {
+      raster::as.factor(projected)
+    } else {
+      projected
+    }
+
+  }
 }
 
 #' @rdname remove

R/leaflet.R

@@ -39,13 +39,11 @@ leafletSizingPolicy <- function(
 #' we may add a circle layer to the map by \code{leaflet(data) \%>\%
 #' addCircles(lat = ~latitude, lng = ~longtitude)}, where the variables in the
 #' formulae will be evaluated in the \code{data}.
-#' @param data a data object. Currently supported objects are matrices, data
-#'   frames, spatial objects from the \pkg{sp} package
-#'   (\code{SpatialPoints}, \code{SpatialPointsDataFrame}, \code{Polygon},
-#'   \code{Polygons}, \code{SpatialPolygons}, \code{SpatialPolygonsDataFrame},
-#'   \code{Line}, \code{Lines}, \code{SpatialLines}, and
-#'   \code{SpatialLinesDataFrame}), and
-#'   spatial data frames from the \pkg{sf} package.
+#' @param data a data object. Currently supported objects are matrix, data
+#' frame, spatial data from the \pkg{sf} package, 
+#' \code{SpatVector} from the \pkg{terra} package, and the Spatial*
+#' objects from the \pkg{sp} package that represent points, lines, or polygons. 
+#'
 #' @param width the width of the map
 #' @param height the height of the map
 #' @param padding the padding of the map
@@ -66,7 +64,7 @@ leaflet <- function(data = NULL, width = NULL, height = NULL,
      !inherits(options[["crs"]], "leaflet_crs")) {
     stop("CRS in mapOptions should be a return value of leafletCRS() function")
   }
-
+  
   map <- htmlwidgets::createWidget(
     "leaflet",
     structure(