Make spatial R packages optional

bodkan · Jul 13, 2023 · 7a10eaa · 7a10eaa
1 parent 2b20a22
commit 7a10eaa
Show file tree

Hide file tree

Showing 7 changed files with 66 additions and 12 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -32,17 +32,13 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 SystemRequirements: 'SLiM' is a forward simulation software for population genetics and evolutionary biology. See <https://messerlab.org/slim/> for installation instructions and further information. The 'Python' coalescent framework 'msprime' and the 'tskit' module can by installed by following the instructions at <https://tskit.dev/>.
 Imports:
-    sf,
-    stars,
     ggplot2,
     dplyr,
     purrr,
     readr,
     magrittr,
     reticulate,
     tidyr,
-    rnaturalearth,
-    gganimate,
     png,
     ijtiff,
     shinyWidgets,
@@ -51,6 +47,10 @@ Imports:
     scales
 Suggests:
     testthat (>= 3.0.0),
+    sf,
+    stars,
+    rnaturalearth,
+    gganimate,
     knitr,
     rmarkdown,
     admixr,

diff --git a/R/compilation.R b/R/compilation.R
@@ -76,6 +76,8 @@ compile_model <- function(populations, generation_time, path = NULL, resolution
   else
     map <- NULL
 
+  if (!is.null(map)) check_spatial_pkgs()
+
   if (!is.null(map) && length(maps) != length(populations))
     warning("Model containing a mix of spatial and non-spatial populations will be compiled.\n",
             "Although this is definitely supported, make sure this is really what you want.",

diff --git a/R/interface.R b/R/interface.R
@@ -95,6 +95,8 @@ population <- function(name, time, N, parent = NULL, map = FALSE,
     map <- attr(parent, "map")
 
   if (inherits(map, "slendr_map")) {
+    check_spatial_pkgs()
+
     # define the population range as a simple geometry object
     # and bind it with the annotation info into an sf object
     if (is.null(polygon) && is.null(center) && is.null(radius)) {
@@ -178,6 +180,8 @@ move <- function(pop, trajectory, end, start, overlap = 0.8, snapshots = NULL,
                  verbose = TRUE) {
   if (!has_map(pop)) stop("This operation is only allowed for spatial models", call. = FALSE)
 
+  check_spatial_pkgs()
+
   check_event_time(c(start, end), pop)
   check_removal_time(start, pop)
   check_removal_time(end, pop)
@@ -330,6 +334,8 @@ expand_range <- function(pop, by, end, start, overlap = 0.8, snapshots = NULL,
                          polygon = NULL, lock = FALSE, verbose = TRUE) {
   if (!has_map(pop)) stop("This operation is only allowed for spatial models", call. = FALSE)
 
+  check_spatial_pkgs()
+
   start <- as.integer(round(start))
   end <- as.integer(round(end))
 
@@ -370,6 +376,10 @@ expand_range <- function(pop, by, end, start, overlap = 0.8, snapshots = NULL,
 #' @example man/examples/model_definition.R
 shrink_range <- function(pop, by, end, start, overlap = 0.8, snapshots = NULL,
                          lock = FALSE, verbose = TRUE) {
+  if (!has_map(pop)) stop("This operation is only allowed for spatial models", call. = FALSE)
+
+  check_spatial_pkgs()
+
   shrink_or_expand(pop, -by, end, start, overlap, snapshots, polygon = NULL, lock, verbose)
 }
 
@@ -404,8 +414,9 @@ shrink_range <- function(pop, by, end, start, overlap = 0.8, snapshots = NULL,
 #' @example man/examples/model_definition.R
 set_range <- function(pop, time, center = NULL, radius = NULL,
                       polygon = NULL, lock = FALSE) {
-  if (!has_map(pop))
-    stop("This operation is only allowed for spatial models", call. = FALSE)
+  if (!has_map(pop)) stop("This operation is only allowed for spatial models", call. = FALSE)
+
+  check_spatial_pkgs()
 
   check_event_time(time, pop)
   check_removal_time(time, pop)
@@ -562,6 +573,8 @@ set_dispersal <- function(pop, time, competition = NA, mating = NA, dispersal =
                           dispersal_fun = NULL) {
   if (!has_map(pop)) stop("This operation is only allowed for spatial models", call. = FALSE)
 
+  check_spatial_pkgs()
+
   if (is.na(competition) && is.na(mating) && is.na(dispersal) &&
       is.null(dispersal_fun))
     stop("At least one spatial interaction parameter must be specified", call. = FALSE)
@@ -743,6 +756,8 @@ gene_flow <- function(from, to, rate, start, end, overlap = TRUE) {
 #' @example man/examples/spatial_functions.R
 world <- function(xrange, yrange, landscape = "naturalearth", crs = NULL,
                   scale = c("small", "medium", "large")) {
+  check_spatial_pkgs()
+
   if (length(xrange) != 2 || length(yrange) != 2)
     stop("Horizontal (i.e. longitude) and vertical (i.e. latitude) must be\n",
          "specified as two-dimensional vectors such as:\n",
@@ -852,6 +867,8 @@ world <- function(xrange, yrange, landscape = "naturalearth", crs = NULL,
 #'
 #' @example man/examples/spatial_functions.R
 region <- function(name = NULL, map = NULL, center = NULL, radius = NULL, polygon = NULL) {
+  check_spatial_pkgs()
+
   # for accurate circular areas see: https://stackoverflow.com/a/65280376
   if (is.null(name)) name <- "unnamed region"
   region <- sf::st_sf(
@@ -989,6 +1006,8 @@ reproject <- function(from, to, x = NULL, y = NULL, coords = NULL, model = NULL,
 #'
 #' @example man/examples/spatial_functions.R
 join <- function(x, y, name = NULL) {
+  check_spatial_pkgs()
+
   if (!inherits(x, "slendr")) x <- region(polygon = x)
   if (!inherits(y, "slendr")) y <- region(polygon = y)
 
@@ -1015,6 +1034,8 @@ join <- function(x, y, name = NULL) {
 #'
 #' @export
 overlap <- function(x, y, name = NULL) {
+  check_spatial_pkgs()
+
   if (!inherits(x, "slendr")) x <- region(polygon = x)
   if (!inherits(y, "slendr")) y <- region(polygon = y)
 

diff --git a/R/tree-sequences.R b/R/tree-sequences.R
@@ -912,8 +912,10 @@ ts_phylo <- function(ts, i, mode = c("index", "position"),
       )
     )
   }
-  if (type == "SLiM" && spatial)
+  if (type == "SLiM" && spatial) {
+    check_spatial_pkgs()
     data <- sf::st_as_sf(data)
+  }
 
   class(data) <- set_class(data, "nodes")
 
@@ -1000,6 +1002,8 @@ ts_phylo <- function(ts, i, mode = c("index", "position"),
 #' ts_nodes(ts)
 #' @export
 ts_nodes <- function(x, sf = TRUE) {
+  if (sf) check_spatial_pkgs()
+
   if (!inherits(x, "slendr_ts") && !inherits(x, "slendr_phylo"))
     stop("Annotation data table can be only extracted for a slendr tree sequence\n",
          "object or a phylo object created by the ts_phylo function", call. = FALSE)
@@ -1185,6 +1189,7 @@ ts_ancestors <- function(ts, x, verbose = FALSE, complete = TRUE) {
 
   model <- attr(ts, "model")
   spatial <- attr(ts, "spatial")
+  if (spatial) check_spatial_pkgs()
   from_slendr <- !is.null(model)
 
   edges <- ts_table(ts, "edges")
@@ -1313,6 +1318,7 @@ ts_descendants <- function(ts, x, verbose = FALSE, complete = TRUE) {
 
   model <- attr(ts, "model")
   spatial <- attr(ts, "spatial")
+  if (spatial) check_spatial_pkgs()
   from_slendr <- !is.null(model)
 
   edges <- ts_table(ts, "edges")
@@ -2606,6 +2612,7 @@ get_annotated_edges <- function(x) {
   data <- ts_nodes(x) %>% dplyr::as_tibble()
   source <- if (inherits(x, "slendr_phylo")) "tree" else "tskit"
   spatial <- attr(x, "spatial")
+  if (spatial) check_spatial_pkgs()
   from_slendr <- !is.null(attr(x, "model"))
 
   if (spatial && any(sf::st_is_empty(data$location))) {

diff --git a/R/utils.R b/R/utils.R
@@ -715,6 +715,25 @@ order_pops <- function(populations, direction) {
   names(split_times)
 }
 
+check_spatial_pkgs <- function(error = TRUE) {
+  missing <- !all(c(requireNamespace("sf", quietly = TRUE),
+                    requireNamespace("stars", quietly = TRUE),
+                    requireNamespace("rnaturalearth", quietly = TRUE)))
+  msg <- paste0(
+    "In order to use spatial features of slendr, packages 'sf', 'stars',\n",
+    "and 'rnaturalearth' are required but not all are present.\n\n",
+    "You can install all of them with\n",
+    "  `install.packages(\"sf\", \"stars\", \"rnaturalearth\")`."
+  )
+
+  if (missing) {
+    if (error)
+      stop(msg, call. = FALSE)
+    else
+      packageStartupMessage(paste0(msg, "\n--------------------"))
+  }
+}
+
 #' Pipe operator
 #'
 #' @return See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details.

diff --git a/R/visualization.R b/R/visualization.R
@@ -25,7 +25,8 @@ plot_map <- function(..., time = NULL, gene_flow = FALSE,
                      graticules = "original",
                      intersect = TRUE, show_map = TRUE,
                      title = NULL, interpolated_maps = NULL) {
-# @importFrom ggplot2 ggplot geom_sf aes scale_fill_discrete scale_color_discrete guides guide_legend geom_point geom_segment arrow geom_sf_label labs theme_bw expand_limits
+  check_spatial_pkgs()
+
   if (!graticules %in% c("internal", "original"))
     stop("Graticules can be either 'original' or 'internal'", call. = FALSE)
 
@@ -523,6 +524,8 @@ plot_model <- function(model, sizes = TRUE, proportions = FALSE, gene_flow = TRU
 #' @importFrom ggplot2 geom_point aes theme element_blank ggtitle
 #' @export
 animate_model <- function(model, file, steps, gif = NULL, width = 800, height = 560) {
+  check_spatial_pkgs()
+
   if (!requireNamespace("magick", quietly = TRUE))
     message("For rendering animated GIFs, please install the R package ",
             "magick by calling `install.packages(\"magick\")")

diff --git a/R/zzz.R b/R/zzz.R
@@ -20,9 +20,9 @@ PYTHON_ENV <-
   path_check <- all(Sys.which("slim") != "")
   if (!path_check) {
     packageStartupMessage(
-      "The slim binary was not found in your $PATH variable. Most of\n",
-      "the functionality in this package will work without any issues\n",
-      "but you will not be able to simulate data with the `slim()` function.\n",
+      "The 'slim' binary could not be found in your $PATH. Most of\n",
+      "the functionality of slendr will work without any issues but\n",
+      "you will not be able to simulate data with the `slim()` function.\n",
       "\nIf you want to run SLiM simulations, make sure to modify the $PATH\n",
       "variable so that it points to the directory containing the slim\n",
       "command-line program. One easy way to do this is to add this:\n\n",
@@ -40,6 +40,8 @@ PYTHON_ENV <-
       )
   }
 
+  check_spatial_pkgs(error = FALSE)
+
   if (!is_slendr_env_present()) {
     if (!getOption("slendr.custom_env")) {
       version <- strsplit(PYTHON_ENV, "_")[[1]] %>% gsub(".*-", "", .)
@@ -48,7 +50,7 @@ PYTHON_ENV <-
           "msprime (%s), tskit (%s), and pyslim (%s) has not been found.\n"),
           version[1], version[2], version[3], version[4]),
           "\nYou can setup a pre-configured environment with all of slendr's Python\n",
-          "dependencies automatically by running the function setup_env()."
+          "dependencies automatically by running the function `setup_env()`."
       )
     }
   }