Support nativeRaster objects in annotation_raster() and raster2uri() (#2174)

zeehio · web-flow · commit 32567a067afa · 2022-09-20T10:11:22.000-05:00
* Add failing test with native raster

* Support nativeRaster objects in raster2uri

* News entry for nativeRaster support

* Update NEWS entry with pull request number

* Fix typo

* Move NEWS entry to new features section
diff --git a/NEWS.md b/NEWS.md
@@ -8,6 +8,8 @@
 
 * `ggplotly()` now supports the `{ggalluvial}` package. (#2061, thanks @moutikabdessabour)
 * `highlight()` now supports `on="plotly_selecting"`, enabling client-side linked brushing via mouse click+drag (no mouse-up event required, as with `on="plotly_selected"`). (#1280)
+* `raster2uri()` supports nativeRaster objects. This enables nativeRaster support for
+  the `annotation_raster()` geom (#2174, @zeehio).
 
 ## Bug fixes
 
diff --git a/R/helpers.R b/R/helpers.R
@@ -219,14 +219,19 @@ plotly_empty <- function(...) {
 raster2uri <- function(r, ...) {
   try_library("png", "raster2uri")
   # should be 4 x n matrix
-  r <- grDevices::as.raster(r, ...)
-  rgbs <- col2rgb(c(r), alpha = T) / 255
-  nr <- dim(r)[1]
-  nc <- dim(r)[2]
-  reds <- matrix(rgbs[1, ], nrow = nr, ncol = nc, byrow = TRUE)
-  greens <- matrix(rgbs[2, ], nrow = nr, ncol = nc, byrow = TRUE)
-  blues <- matrix(rgbs[3, ], nrow = nr, ncol = nc, byrow = TRUE)
-  alphas <- matrix(rgbs[4, ], nrow = nr, ncol = nc, byrow = TRUE)
-  png <- array(c(reds, greens, blues, alphas), dim = c(dim(r), 4))
+  if (inherits(r, "nativeRaster")) {
+    # png::writePNG directly supports nativeRaster objects
+    png <- r
+  } else {
+    r <- grDevices::as.raster(r, ...)
+    rgbs <- col2rgb(c(r), alpha = T) / 255
+    nr <- dim(r)[1]
+    nc <- dim(r)[2]
+    reds <- matrix(rgbs[1, ], nrow = nr, ncol = nc, byrow = TRUE)
+    greens <- matrix(rgbs[2, ], nrow = nr, ncol = nc, byrow = TRUE)
+    blues <- matrix(rgbs[3, ], nrow = nr, ncol = nc, byrow = TRUE)
+    alphas <- matrix(rgbs[4, ], nrow = nr, ncol = nc, byrow = TRUE)
+    png <- array(c(reds, greens, blues, alphas), dim = c(dim(r), 4))
+  }
   base64enc::dataURI(png::writePNG(png), mime = "image/png")
 }
diff --git a/tests/testthat/test-plotly-subplot.R b/tests/testthat/test-plotly-subplot.R
@@ -274,6 +274,21 @@ test_that("shape paper repositioning", {
   expect_equal(y1, c(30, 0.75))
 })
 
+test_that("raster2uri supports nativeRaster objects", {
+  skip_if_not_installed("png")
+
+  r <- as.raster(matrix(c("black", "red", "green", "blue"), ncol = 4L))
+  nr <- structure(
+    c(-16777216L, -16776961L, -16711936L, -65536L),
+    dim = c(1L, 4L),
+    class = "nativeRaster",
+    channels = 4L
+  )
+  uri_r <- raster2uri(r)
+  uri_nr <- raster2uri(nr)
+  expect_equal(uri_r, uri_nr)
+})
+
 
 test_that("image paper repositioning", {
   skip_if_not_installed("png")
