add filter argument

NEWS.md

@@ -5,6 +5,7 @@
 * added browse_phylopic function (#60)
 * added preview argument to get_phylopic (#59)
 * switched to {maps} package in base R advanced vignette
+* added filter (license) argument to get_uuid, pick_phylo, add_phylopic_base, add_phylopic, and geom_phylopic (#72)
 * added img argument to get_uuid and get_attribution
 
 # rphylopic 1.1.1

R/add_phylopic.r

@@ -8,6 +8,10 @@
 #' @param name \code{character}. A taxonomic name to be passed to [get_uuid()].
 #' @param uuid \code{character}. A valid uuid for a PhyloPic silhouette (such as
 #'   that returned by [get_uuid()] or [pick_phylopic()]).
+#' @param filter \code{character}. Filter by usage license if `name` is defined.
+#'   Use "by" to limit results to images which do not require attribution, "nc" 
+#'   for images which allows commercial usage, and "sa" for images without a 
+#'   StandAlone clause. The user can also combine these filters as a vector.
 #' @param x \code{numeric}. x value of the silhouette center.
 #' @param y \code{numeric}. y value of the silhouette center.
 #' @param ysize \code{numeric}. Height of the silhouette. The width is
@@ -68,7 +72,7 @@
 #'                color = cols, alpha = alpha, angle = angle,
 #'                horizontal = hor, vertical = ver)
 #' p + ggtitle("R Cat Herd!!")
-add_phylopic <- function(img = NULL, name = NULL, uuid = NULL,
+add_phylopic <- function(img = NULL, name = NULL, uuid = NULL, filter = NULL,
                          x, y, ysize = Inf,
                          alpha = 1, color = "black",
                          horizontal = FALSE, vertical = FALSE, angle = 0,
@@ -94,10 +98,12 @@
   angle <- rep_len(angle, max_len)
 
   # Put together all of the variables
-  args <- list(geom = GeomPhylopic, x = x, y = y, size = ysize,
+  args <- list(geom = GeomPhylopic,
+               x = x, y = y, size = ysize,
                alpha = alpha, color = color,
                horizontal = horizontal, vertical = vertical, angle = angle,
-               remove_background = remove_background)
+               remove_background = remove_background,
+               filter = list(filter))
   # Only include the one silhouette argument
   if (!is.null(img)) {
     if (is.list(img)) {

R/add_phylopic_base.r

@@ -8,6 +8,10 @@
 #' @param name \code{character}. A taxonomic name to be passed to [get_uuid()].
 #' @param uuid \code{character}. A valid uuid for a PhyloPic silhouette (such as
 #'   that returned by [get_uuid()] or [pick_phylopic()]).
+#' @param filter \code{character}. Filter by usage license if `name` is defined.
+#'   Use "by" to limit results to images which do not require attribution, "nc" 
+#'   for images which allows commercial usage, and "sa" for images without a 
+#'   StandAlone clause. The user can also combine these filters as a vector.
 #' @param x \code{numeric}. x value of the silhouette center. Ignored if `y` and
 #'   `ysize` are not specified.
 #' @param y \code{numeric}. y value of the silhouette center. Ignored if `x` and
@@ -82,7 +86,8 @@
 #' add_phylopic_base(img = cat, alpha = 0.2)
 #' # overlay smaller cats
 #' add_phylopic_base(img = cat, x = posx, y = posy, ysize = size, alpha = 0.8)
 add_phylopic_base <- function(img = NULL, name = NULL, uuid = NULL,
+                              filter = NULL,
                               x = NULL, y = NULL, ysize = NULL,
                               alpha = 1, color = "black",
                               horizontal = FALSE, vertical = FALSE, angle = 0,
@@ -104,11 +109,15 @@
     # Get PhyloPic for each unique name
     name_unique <- unique(name)
     imgs <- sapply(name_unique, function(x) {
-      url <- tryCatch(get_uuid(name = x, url = TRUE),
+      url <- tryCatch(get_uuid(name = x, filter = filter, url = TRUE),
                       error = function(cond) NA)
       if (is.na(url)) {
-        warning(paste0("`name` ", '"', x, '"',
-                       " returned no PhyloPic results."))
+        text <- paste0("`name` ", '"', name, '"')
+        if (!is.null(filter)) {
+          text <- paste0(text, " with `filter` ", '"',
+                         paste0(filter, collapse = "/"), '"')
+        }
+        warning(paste0(text, " returned no PhyloPic results."))
         return(NULL)
       }
       get_svg(url)
@@ -169,7 +178,7 @@
     # grobify and plot
     if (is(img, "Picture")) { # svg
       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 &&
@@ -182,5 +191,5 @@
       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))
 }

R/geom_phylopic.R

@@ -38,16 +38,22 @@
 #' - vertical
 #' - angle
 #'
-#' Learn more about setting these aesthetics in [add_phylopic()].
+#'   Learn more about setting these aesthetics in [add_phylopic()].
 #'
 #' @param show.legend logical. Should this layer be included in the legends?
 #'   `FALSE`, the default, never includes, `NA` includes if any aesthetics are
 #'   mapped, and `TRUE` always includes. It can also be a named logical vector
 #'   to finely select the aesthetics to display.
 #' @param remove_background \code{logical}. Should any white background be
 #'   removed from the silhouette(s)? See [recolor_phylopic()] for details.
+#' @param filter \code{character}. Filter by usage license if using the `name`
+#'   aesthetic. Use "by" to limit results to images which do not require
+#'   attribution, "nc" for images which allows commercial usage, and "sa" for
+#'   images without a StandAlone clause. The user can also combine these
+#'   filters as a vector.
 #' @inheritParams ggplot2::layer
 #' @inheritParams ggplot2::geom_point
+#' @inheritParams pick_phylopic
 #' @importFrom ggplot2 layer
 #' @export
 #' @examples
@@ -64,7 +70,8 @@ geom_phylopic <- function(mapping = NULL, data = NULL,
                           na.rm = FALSE,
                           show.legend = FALSE,
                           inherit.aes = TRUE,
-                          remove_background = TRUE) {
+                          remove_background = TRUE,
+                          filter = NULL) {
   if (!is.logical(remove_background)) {
     stop("`remove_background` should be a logical value.")
   }
@@ -79,6 +86,7 @@ geom_phylopic <- function(mapping = NULL, data = NULL,
     params = list(
       na.rm = na.rm,
       remove_background = remove_background,
+      filter = filter,
       ...
     )
   )
@@ -94,7 +102,8 @@ GeomPhylopic <- ggproto("GeomPhylopic", Geom,
   default_aes = aes(size = 1.5, alpha = 1, color = "black",
                     horizontal = FALSE, vertical = FALSE, angle = 0),
   draw_panel = function(self, data, panel_params, coord, na.rm = FALSE,
-                        remove_background = TRUE) {
+                        remove_background = TRUE, filter = NULL) {
+    if (is.list(filter)) filter <- filter[[1]]
     # Clean and transform data
     data <- remove_missing(data, na.rm = na.rm, c("img", "name", "uuid"))
     data <- coord$transform(data, panel_params)
@@ -119,11 +128,15 @@ GeomPhylopic <- ggproto("GeomPhylopic", Geom,
       # Get PhyloPic for each unique name
       name_unique <- unique(data$name)
       imgs <- sapply(name_unique, function(name) {
-        url <- tryCatch(get_uuid(name = name, url = TRUE),
+        url <- tryCatch(get_uuid(name = name, url = TRUE, filter = filter),
                         error = function(cond) NA)
         if (is.na(url)) {
-          warning(paste0("`name` ", '"', name, '"',
-                         " returned no PhyloPic results."))
+          text <- paste0("`name` ", '"', name, '"')
+          if (!is.null(filter)) {
+            text <- paste0(text, " with `filter` ", '"',
+                           paste0(filter, collapse = "/"), '"')
+          }
+          warning(paste0(text, " returned no PhyloPic results."))
           return(NULL)
         }
         get_svg(url)

R/get_uuid.R

@@ -14,6 +14,10 @@
 #'   the requested `name`, multiple silhouettes might exist. If `n` exceeds
 #'   the number of available images, all available uuids will be returned.
 #'   This argument defaults to 1.
+#' @param filter \code{character}. Filter uuid(s) by usage license. Use "by" to
+#'   limit results to image uuids which do not require attribution, "nc" for
+#'   image uuids which allow commercial usage, and "sa" for image uuids without
+#'   a StandAlone clause. The user can also combine these filters as a vector.
 #' @param url \code{logical}. If \code{FALSE} (default), only the uuid is
 #'   returned. If \code{TRUE}, a valid PhyloPic image url of the uuid is
 #'   returned.
@@ -29,7 +33,8 @@
 #' @examples
 #' uuid <- get_uuid(name = "Acropora cervicornis")
 #' uuid <- get_uuid(name = "Dinosauria", n = 5, url = TRUE)
-get_uuid <- function(name = NULL, img = NULL, n = 1, url = FALSE) {
+get_uuid <- function(name = NULL, img = NULL, n = 1, filter = NULL,
+                     url = FALSE) {
   # Handle img -----------------------------------------------------------
   if (!is.null(img)) {
     if (is.list(img)) {
@@ -56,6 +61,9 @@ get_uuid <- function(name = NULL, img = NULL, n = 1, url = FALSE) {
   if (!is.numeric(n)) {
     stop("`n` should be of class numeric.")
   }
+  if (!is.null(filter) && !all(filter %in% c("by", "nc", "sa"))) {
+    stop("`filter` should be NULL or either: 'by', 'nc', or 'sa'.")
+  }
   if (!is.logical(url)) {
     stop("`url` should be of class logical.")
   }
@@ -68,6 +76,10 @@ get_uuid <- function(name = NULL, img = NULL, n = 1, url = FALSE) {
   # Get clade uuid
   opts$page <- 0
   opts$embed_items <- "true"
+  # Filter options
+  if ("by" %in% filter) opts$filter_license_by <- "false"
+  if ("nc" %in% filter) opts$filter_license_nc <- "false"
+  if ("sa" %in% filter) opts$filter_license_sa <- "false"
   api_return <- phy_GET("nodes", opts)
   clade_uuid <- api_return$`_embedded`$items$uuid
   if (is.null(clade_uuid)) {
@@ -89,6 +101,10 @@ get_uuid <- function(name = NULL, img = NULL, n = 1, url = FALSE) {
   opts <- list()
   # First uuid should always be the closest link
   opts$filter_clade <- clade_uuid[1]
+  # Filter options
+  if ("by" %in% filter) opts$filter_license_by <- "false"
+  if ("nc" %in% filter) opts$filter_license_nc <- "false"
+  if ("sa" %in% filter) opts$filter_license_sa <- "false"
   api_return <- phy_GET("images", opts)
   total_items <- api_return$totalItems
   if (total_items < n) {

R/pick_phylopic.R

@@ -16,6 +16,10 @@ utils::globalVariables(c("x", "y", "uuid", "label"))
 #'   of available images, all available uuids will be returned. Defaults to 5.
 #' @param view \code{numeric}. Number of silhouettes that should be plotted at
 #'   the same time. Defaults to 1.
+#' @param filter \code{character}. Filter uuid(s) by usage license. Use "by"
+#'   to limit results to image uuids which do not require attribution, "nc" 
+#'   for image uuids which allow commercial usage, and "sa" for image uuids 
+#'   without a StandAlone clause. The user can also combine these filters.
 #' @param auto \code{numeric}. This argument allows the user to automate input
 #'   into the menu choice. If the input value is `1`, the first returned image
 #'   will be selected. If the input value is `2`, requested images will be
@@ -48,7 +52,8 @@ utils::globalVariables(c("x", "y", "uuid", "label"))
 #' # 3 x 3 pane layout
 #' img <- pick_phylopic(name = "Scleractinia", n = 9, view = 9)
 #' }
-pick_phylopic <- function(name = NULL, n = 5, view = 1, auto = NULL) {
+pick_phylopic <- function(name = NULL, n = 5, view = 1, 
+                          filter = NULL, auto = NULL) {
   # Error handling
   if (!is.null(auto) && !auto %in% c(1, 2)) {
     stop("`auto` must be of value: NULL, 1, or 2")
@@ -76,7 +81,7 @@ pick_phylopic <- function(name = NULL, n = 5, view = 1, auto = NULL) {
   }
 
   # Get uuids
-  uuids <- get_uuid(name = name, n = n, url = FALSE)
+  uuids <- get_uuid(name = name, n = n, filter = filter, url = FALSE)
   # Record length
   n_uuids <- length(uuids)
 

tests/testthat/test-get_uuid.R

@@ -4,8 +4,11 @@ test_that("get_uuid works", {
   expect_true(is.character(get_uuid(name = "Acropora cervicornis")))
   expect_true(is.character(get_uuid(name = "Tyrannosaurus", url = TRUE)))
   expect_true(is.character(get_uuid(name = "Acropora", n = 1, url = TRUE)))
-  expect_true(length(get_uuid(name = NULL, n = 100)) == 100)
-  expect_true(length(get_uuid(name = NULL, n = 100, url = TRUE)) == 100)
+  expect_true(length(get_uuid(name = NULL, n = 10)) == 10)
+  expect_true(length(get_uuid(name = NULL, n = 10, url = TRUE)) == 10)
+  expect_true(length(get_uuid(name = NULL, n = 10, filter = "by")) == 10)
+  expect_true(length(get_uuid(name = NULL, n = 10, filter = "nc")) == 10)
+  expect_true(length(get_uuid(name = NULL, n = 10, filter = "sa")) == 10)
   uuid <- get_uuid(name = "Scleractinia")
   img <- get_phylopic(uuid = uuid)
   expect_equal(length(get_uuid(img = img)), 1)
@@ -14,6 +17,7 @@ test_that("get_uuid works", {
   expect_warning(is.character(get_uuid(name = "Acropora", n = 50, url = TRUE)))
   # Expect errors
   expect_error(get_uuid(name = 1))
+  expect_error(get_uuid(n = 10, filter = "test"))
   expect_error(get_uuid(name = "Acropora cervicornis", url = 1))
   expect_error(get_uuid(name = "Acropora cervicornis", n = "5"))
   expect_error(get_uuid(img = "5d646d5a-b2dd-49cd-b450-4132827ef25e"))