diff --git a/NAMESPACE b/NAMESPACE index c3036602..f3cd0ac5 100644 --- 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 index 610c660f..57f2bc48 100644 --- 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 index 7f351780..beab4c46 100644 --- 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 index ff6bf884..7470d734 100644 --- 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) }