Fixes for Fedora

palaeoverse · Jul 7, 2023 · 749d520 · 749d520
1 parent bddc6ab
commit 749d520
Show file tree

Hide file tree

Showing 4 changed files with 47 additions and 24 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -60,6 +60,7 @@ importFrom(httr,GET)
 importFrom(httr,content)
 importFrom(jsonlite,fromJSON)
 importFrom(methods,is)
+importFrom(methods,slotNames)
 importFrom(pbapply,pblapply)
 importFrom(png,readPNG)
 importFrom(rsvg,rsvg_png)

diff --git a/R/add_phylopic_base.r b/R/add_phylopic_base.r
@@ -49,7 +49,7 @@
 #' @importFrom graphics par grconvertX grconvertY
 #' @importFrom grid grid.raster
 #' @importFrom grImport2 grid.picture
-#' @importFrom methods is
+#' @importFrom methods is slotNames
 #' @export
 #' @examples
 #' # single image
@@ -168,7 +168,16 @@ add_phylopic_base <- function(img = NULL, name = NULL, uuid = NULL,
 
     # grobify and plot
     if (is(img, "Picture")) { # svg
-      grid.picture(img, x = x, y = y, height = ysize, expansion = 0)
+      if ("summary" %in% slotNames(img) &&
+          all(c("xscale", "yscale") %in% slotNames(img@summary)) &&
+          is.numeric(img@summary@xscale) && length(img@summary@xscale) == 2 &&
+          all(is.finite(img@summary@xscale)) && diff(img@summary@xscale) != 0 &&
+          is.numeric(img@summary@yscale) && length(img@summary@yscale) == 2 &&
+          all(is.finite(img@summary@yscale)) && diff(img@summary@yscale) != 0) {
+        grid.picture(img, x = x, y = y, height = ysize, expansion = 0)
+      } else {
+        return(NULL)
+      }
     } else { # png
       grid.raster(img, x = x, y = y, height = ysize)
     }

diff --git a/R/geom_phylopic.R b/R/geom_phylopic.R
@@ -184,7 +184,8 @@ GeomPhylopic <- ggproto("GeomPhylopic", Geom,
 )
 
 #' @importFrom grImport2 pictureGrob
-#' @importFrom grid rasterGrob gList gTree
+#' @importFrom grid rasterGrob gList gTree nullGrob
+#' @importFrom methods slotNames
 phylopicGrob <- function(img, x, y, height, color, alpha,
                          horizontal, vertical, angle,
                          remove_background) {
@@ -198,12 +199,21 @@ phylopicGrob <- function(img, x, y, height, color, alpha,
 
   # grobify
   if (is(img, "Picture")) { # svg
-    # modified from
-    # https://github.com/k-hench/hypoimg/blob/master/R/hypoimg_recolor_svg.R
-    img_grob <- pictureGrob(img, x = x, y = y, height = height,
-                            default.units = "native", expansion = 0)
-    img_grob <- gList(img_grob)
-    img_grob <- gTree(children = img_grob)
+    if ("summary" %in% slotNames(img) &&
+        all(c("xscale", "yscale") %in% slotNames(img@summary)) &&
+        is.numeric(img@summary@xscale) && length(img@summary@xscale) == 2 &&
+        all(is.finite(img@summary@xscale)) && diff(img@summary@xscale) != 0 &&
+        is.numeric(img@summary@yscale) && length(img@summary@yscale) == 2 &&
+        all(is.finite(img@summary@yscale)) && diff(img@summary@yscale) != 0) {
+      # modified from
+      # https://github.com/k-hench/hypoimg/blob/master/R/hypoimg_recolor_svg.R
+      img_grob <- pictureGrob(img, x = x, y = y, height = height,
+                              default.units = "native", expansion = 0)
+      img_grob <- gList(img_grob)
+      img_grob <- gTree(children = img_grob)
+    } else {
+      img_grob <- nullGrob()
+    }
   } else { # png
     img_grob <- rasterGrob(img, x = x, y = y, height = height,
                            default.units = "native")

diff --git a/R/phylopic_utils.R b/R/phylopic_utils.R
@@ -231,28 +231,31 @@ rgb_to_rgba <- function(img) {
 recolor_phylopic.Picture <- function(img, alpha = 1, color = NULL,
                                      remove_background = TRUE) {
   img <- recolor_content(img, alpha, color, remove_background)
+  if (length(img@content) == 0) stop("Invalid 'Picture' object")
   return(img)
 }
 
+#' @importFrom methods slotNames
 recolor_content <- function(x, alpha, color, remove_background) {
-  if (is(x@content[[1]], "PicturePath")) {
-    tmp <- lapply(x@content, function(path) {
+  tmp <- lapply(x@content, function(element) {
+    if (is(element, "PicturePath")) {
       # a bit of a hack until PhyloPic fixes these white backgrounds
-      if (remove_background && path@gp$fill %in% c("#FFFFFFFF", "#FFFFFF")) {
-        NULL
+      if (remove_background && "gp" %in% slotNames(element) &&
+          "fill" %in% names(element@gp) &&
+          element@gp$fill %in% c("#FFFFFFFF", "#FFFFFF")) {
+        return(NULL)
       } else {
-        path@gp$alpha <- alpha
+        element@gp$alpha <- alpha
         if (!is.null(color)) {
-          path@gp$fill <- color
+          element@gp$fill <- color
         }
-        path
+        return(element)
       }
-    })
-    x@content <- Filter(function(path) !is.null(path), tmp)
-    return(x)
-  } else { # need to go another level down
-    x@content <- lapply(x@content, recolor_content, alpha = alpha,
-                        color = color, remove_background = remove_background)
-    return(x)
-  }
+    } else if (is(element, "PictureGroup")) {
+      # need to go another level down
+      recolor_content(element, alpha, color, remove_background)
+    }
+  })
+  x@content <- Filter(function(element) !is.null(element), tmp)
+  return(x)
 }