Merge branch 'main' into preview-arg

.Rbuildignore

@@ -17,5 +17,7 @@ Makefile
 ^\.github$
 ^_pkgdown\.yml$
 ^docs$
+^doc$
 ^pkgdown$
 ^CRAN-SUBMISSION$
+^revdep$

.gitignore

@@ -56,4 +56,6 @@ data-raw/
 inst/doc
 /doc/
 /Meta/
-CRAN-SUBMISSION
+CRAN-SUBMISSION
+
+/revdep

DESCRIPTION

@@ -3,7 +3,7 @@ Title: Get Silhouettes of Organisms from PhyloPic
 Description: Work with the PhyloPic Web Service (<http://api-docs.phylopic.org/v2/>) 
     to fetch silhouette images of organisms. Includes functions for adding 
     silhouettes to both base R plots and ggplot2 plots.
-Version: 1.0.0.9002
+Version: 1.1.1.9000
 Authors@R: c(
     person(given = "William", family = "Gearty", email = "[email protected]",
       role = c("aut", "cre"), comment = c(ORCID = "0000-0003-0076-3262")),
@@ -15,9 +15,10 @@ Authors@R: c(
       role = c("ctb"))
   )
 License: GPL (>= 3)
-Language: en-GB
+Language: en-US
 Encoding: UTF-8
 LazyData: true
+biocViews:
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Depends: 
@@ -40,9 +41,18 @@ Suggests:
     vdiffr (>= 1.0.0),
     knitr,
     rmarkdown,
-    covr
+    covr,
+    phytools,
+    palaeoverse,
+    ggtree,
+    geodata,
+    ape,
+    deeptime,
+    palmerpenguins,
+    raster
 Config/testthat/edition: 3
 URL: https://rphylopic.palaeoverse.org,
      https://github.com/palaeoverse-community/rphylopic,
      https://palaeoverse.org
 BugReports: https://github.com/palaeoverse-community/rphylopic/issues
+VignetteBuilder: knitr

NAMESPACE

@@ -44,6 +44,8 @@ importFrom(grImport2,applyTransform)
 importFrom(grImport2,grid.picture)
 importFrom(grImport2,pictureGrob)
 importFrom(grImport2,readPicture)
+importFrom(graphics,grconvertX)
+importFrom(graphics,grconvertY)
 importFrom(graphics,par)
 importFrom(grid,gList)
 importFrom(grid,gTree)
@@ -58,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)

NEWS.md

@@ -1,5 +1,11 @@
-rphylopic (development version)
-==============
+# rphylopic (development version)
+
+# rphylopic 1.1.1
+
+* Minor fixes for Fedora
+* Better handling of malformed Picture objects
+
+# rphylopic 1.1.0
 
 * added preview argument to get_phylopic (#59)
 * added functions for transforming PhyloPic silhouettes (flipping and rotating)
@@ -11,10 +17,11 @@ rphylopic (development version)
 * get_phylopic can now return any size raster image (#50)
 * removed the "thumbnail" and "twitter" format options for get_phylopic
 * fixed how silhouettes are gathered from PhyloPic (#51)
-* pick_phylopic updated to allow visualisation of multiple silhouettes at once (#43)
+* pick_phylopic updated to allow visualization of multiple silhouettes at once (#43)
+* fixed add_phylopic_base for multi-panel figures
+* added three vignettes (#49, #55)
 
-rphylopic 1.0.0
-==============
+# rphylopic 1.0.0
 
 * rphylopic has now been transferred to the Palaeoverse community (new maintainer: William Gearty and author: Lewis Jones)
 * The package has been updated to work with PhyloPic API ver. >=2.1.1
@@ -28,8 +35,7 @@ rphylopic 1.0.0
   * save_phylopic: this function enables users to save PhyloPic silhouettes using various formats (replaces save_png)
 
 
-rphylopic 0.3.4
-==============
+# rphylopic 0.3.4
 
 ### NEW FEATURES
 
@@ -39,8 +45,7 @@ rphylopic 0.3.4
   + `messager`
   + `message_parallel` 
 
-rphylopic 0.3.0
-===============
+# rphylopic 0.3.0
 
 ### NEW FEATURES
 
@@ -55,8 +60,7 @@ rphylopic 0.3.0
 * `plot_phylopic_base()` was removed, see `?add_phylopic_base` (#27) (#28)
 
 
-rphylopic 0.2.0
-===============
+# rphylopic 0.2.0
 
 ### NEW FEATURES
 

R/add_phylopic_base.r

@@ -46,10 +46,10 @@
 #'   using [flip_phylopic()] and [rotate_phylopic()].
 #'
 #'   Note that png array objects can only be rotated by multiples of 90 degrees.
-#' @importFrom graphics par
-#' @importFrom grid grid.raster gpar
+#' @importFrom graphics par grconvertX grconvertY
+#' @importFrom grid grid.raster
 #' @importFrom grImport2 grid.picture
-#' @importFrom methods is
+#' @importFrom methods is slotNames
 #' @export
 #' @examples
 #' # single image
@@ -145,31 +145,18 @@ add_phylopic_base <- function(img = NULL, name = NULL, uuid = NULL,
   usr_x <- if (par()$xlog) 10^usr[1:2] else usr[1:2]
   usr_y <- if (par()$ylog) 10^usr[3:4] else usr[3:4]
 
-  # get plot area percentages
-  # note that this means that changing the plot size AFTER plotting may
-  # affect the position of the PhyloPic
-  plt <- par()$plt
-  plt_x <- plt[1:2]
-  plt_y <- plt[3:4]
-
-  # get figure limits
-  width <- diff(usr_x) / diff(plt_x)
-  xlims <- c(usr_x[1] - plt_x[1] * width, usr_x[2] + (1 - plt_x[2]) * width)
-  height <- diff(usr_y) / diff(plt_y)
-  ylims <- c(usr_y[1] - plt_y[1] * height, usr_y[2] + (1 - plt_y[2]) * height)
-
   # set default position and size if need be
   if (is.null(x)) x <- mean(usr_x)
   if (is.null(y)) y <- mean(usr_y)
   if (is.null(ysize)) ysize <- abs(diff(usr_y))
 
-  # convert x, y, and ysize to percentages
-  x <- (x - xlims[1]) / diff(xlims)
-  y <- (y - ylims[1]) / diff(ylims)
-  ysize <- ysize / abs(diff(ylims))
+  # convert x, y, and ysize to normalized device coordinates
+  x <- grconvertX(x, to = "ndc")
+  y <- grconvertY(y, to = "ndc")
+  ysize <- grconvertY(ysize, to = "ndc") - grconvertY(0, to = "ndc")
 
-  tmp <- mapply(function(img, x, y, ysize, alpha, color,
-                         horizontal, vertical, angle) {
+  invisible(mapply(function(img, x, y, ysize, alpha, color,
+                            horizontal, vertical, angle) {
     if (is.null(img)) return(NULL)
 
     if (horizontal || vertical) img <- flip_phylopic(img, horizontal, vertical)
@@ -181,10 +168,19 @@ 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)
     }
   }, img = imgs, x = x, y = y, ysize = ysize, alpha = alpha, color = color,
-     horizontal = horizontal, vertical = vertical, angle = angle)
+     horizontal = horizontal, vertical = vertical, angle = angle))
 }

R/geom_phylopic.R

@@ -37,7 +37,7 @@
 #' - horizontal
 #' - vertical
 #' - angle
-#' 
+#'
 #' Learn more about setting these aesthetics in [add_phylopic()].
 #'
 #' @param show.legend logical. Should this layer be included in the legends?
@@ -52,8 +52,7 @@
 #' @export
 #' @examples
 #' library(ggplot2)
-#' df <- data.frame(x = 2:5, y = seq(10, 25, 5),
-#'                  name = c("cat", "walrus", "house mouse", "iris"))
+#' df <- data.frame(x = c(2, 4), y = c(10, 20), name = c("cat", "walrus"))
 #' ggplot(df) +
 #'   geom_phylopic(aes(x = x, y = y, name = name),
 #'                 color = "purple", size = 10) +
@@ -184,7 +183,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 +198,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")

R/get_uuid.R

@@ -62,7 +62,7 @@ get_uuid <- function(name = NULL, n = 1, url = FALSE) {
       stop(paste0("Image resource not available for '", name, "'. ",
                      "Did you mean one of the following? \n", toString(mch)))
     }
-  } 
+  }
   # Reset options
   opts <- list()
   # First uuid should always be the closest link
@@ -82,7 +82,7 @@ get_uuid <- function(name = NULL, n = 1, url = FALSE) {
     uuids <- api_return$`_links`$items$href
     uuids <- sub("/images/", "", uuids)
     uuids <- sub("(\\?build=\\d+)$", "", uuids)
-    
+
     # Get image URLs --------------------------------------------------------
     if (url) {
       href <- api_return$`_embedded`$items$`_links`$vectorFile$href

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)
 }