Merge pull request #57 from trafficonese/master

Fix makeColor & tests
r-spatial · Dec 9, 2020 · 382c7a1 · 382c7a1
2 parents 51e31b1 + af164eb
commit 382c7a1
Show file tree

Hide file tree

Showing 3 changed files with 25 additions and 14 deletions.
diff --git a/R/utils-color.R b/R/utils-color.R
@@ -75,9 +75,9 @@ makeColorMatrix.numeric <- makeColorMatrix.integer
 
 #' @export
 makeColorMatrix.factor <- function(x, data = NULL, palette = "viridis", ...) {
-  x <- tryCatch(as.integer(as.character(as.factor(x))),
-                error = function(e) as.numeric(as.factor(x)),
-                warning = function(e) as.numeric(as.factor(x)),
+  x <- tryCatch(as.integer(as.character((x))),
+                error = function(e) as.numeric((x)),
+                warning = function(e) as.numeric((x)),
                 finally = function(e) stop("Cannot process factor."))
 
   makeColorMatrix(x, data, palette, ...)
@@ -125,7 +125,7 @@ makeColorMatrix.data.frame <- makeColorMatrix.matrix
 
 #' @export
 makeColorMatrix.list <- function(x, data = NULL, palette = "viridis", ...) {
-  classes <- lapply(x, class)
+  classes <- lapply(x, function(x) class(x)[[1]])
   if (all(classes == "numeric")) {
     x <- unlist(x)
   } else if (all(classes == "matrix")) {
@@ -164,7 +164,7 @@ checkDim <- function(x, data) {
   if (inherits(x, "matrix") || inherits(x, "data.frame")) {
     if (nrow(x) != 1 && nro_d != nrow(x)) {
       warning("Number of rows of color matrix does not match number of data rows.\n",
-              "  Just the first row is taken.")
+              "  Just the first color is used.")
       x <- x[1,,drop = FALSE]
     }
   } else {

diff --git a/tests/testthat/test-leafgl-colors.R b/tests/testthat/test-leafgl-colors.R
@@ -131,7 +131,7 @@ test_that("Character as color", {
   m <- leaflet() %>%
     addGlPolylines(data = lines,
                    color = "FGN",
-                   palette = "rainbow",
+                   palette = "magma",
                    group = "lns");
   expect_is(m, "leaflet")
   expect_is(m$x$calls[[1]]$args[[2]], "json")
@@ -153,7 +153,7 @@ test_that("Formula as color", {
   m <- leaflet() %>%
     addGlPoints(data = pts,
                 fillColor = ~id,
-                palette = "rainbow",
+                palette = "Greens",
                 group = "pts");
   expect_is(m, "leaflet")
   expect_is(m$x$calls[[1]]$args[[2]], "json")
@@ -163,7 +163,7 @@ test_that("Formula as color", {
   m <- leaflet() %>%
     addGlPoints(data = pts,
                 fillColor = ~id,
-                palette = "rainbow",
+                palette = "inferno",
                 group = "pts",
                 src = TRUE)
   expect_is(m, "leaflet")
@@ -182,7 +182,7 @@ test_that("Formula as color", {
   m <- leaflet() %>%
     addGlPolylines(data = lines,
                    color = ~Name,
-                   palette = "rainbow",
+                   palette = "Greens",
                    group = "lns");
   expect_is(m, "leaflet")
   expect_is(m$x$calls[[1]]$args[[2]], "json")
@@ -192,7 +192,7 @@ test_that("Formula as color", {
   m <- leaflet() %>%
     addGlPolylines(data = lines,
                    color = ~Name,
-                   palette = "rainbow",
+                   palette = "inferno",
                    group = "lns",
                    src = TRUE);
   expect_is(m, "leaflet")
@@ -211,7 +211,7 @@ test_that("Formula as color", {
   m <- leaflet() %>%
     addGlPolygons(data = polys,
                   color = ~NAME_1,
-                  palette = "rainbow",
+                  palette = "BuPu",
                   group = "lns");
   expect_is(m, "leaflet")
   expect_is(m$x$calls[[1]]$args[[2]], "json")
@@ -221,7 +221,7 @@ test_that("Formula as color", {
   m <- leaflet() %>%
     addGlPolygons(data = polys,
                   color = ~NAME_1,
-                  palette = "rainbow",
+                  palette = "magma",
                   group = "lns",
                   src = TRUE)
   expect_is(m, "leaflet")
@@ -480,6 +480,15 @@ test_that("List as color", {
   expect_true(validate_json(m$x$calls[[1]]$args[[2]]))
   rm(m)
 
+  m <- expect_warning(leaflet() %>%
+                        addGlPoints(data = pts,
+                                    fillColor = list(cbind(0.1,0.2,0.7),
+                                                     cbind(2,1,0)),
+                                    group = "pts"))
+  expect_is(m, "leaflet")
+  expect_is(m$x$calls[[1]]$args[[2]], "json")
+  expect_true(validate_json(m$x$calls[[1]]$args[[2]]))
+  rm(m)
 
 })
 

diff --git a/tests/testthat/test-leafgl-popup.R b/tests/testthat/test-leafgl-popup.R
@@ -416,10 +416,11 @@ test_that("popup-lines-table", {
 })
 
 test_that("popup-lines-spatial", {
+  popups <- suppressWarnings(sf::as_Spatial(storms))
   ## SpatialLinesDataFrame ##############
   m <- leaflet() %>% addTiles() %>%
     addGlPolylines(data = storms,
-                   popup = sf::as_Spatial(storms),
+                   popup = popups,
                    opacity = 1)
   expect_is(m, "leaflet")
   expect_true(jsonify::validate_json(m$x$calls[[2]]$args[[3]]))
@@ -570,9 +571,10 @@ test_that("popup-polygon-table", {
 
 test_that("popup-polygon-spatial", {
   ## SpatialPolygonsDataFrame ##############
+  popups <- suppressWarnings(sf::as_Spatial(gadm))
   m <- leaflet() %>% addTiles() %>%
     addGlPolygons(data = gadm,
-                   popup = sf::as_Spatial(gadm),
+                   popup = popups,
                    opacity = 1)
   expect_is(m, "leaflet")
   expect_true(jsonify::validate_json(m$x$calls[[2]]$args[[3]]))