Add tests and update message handling

Add test for build_collection_index
New internal bf_msg() handles printing messages
New internal bf_suppress_msg() blocks messages

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: BirdFlowR
 Title: Predict and Visualize Bird Movement
-Version: 0.1.0.9042
+Version: 0.1.0.9043
 Authors@R: 
     c(person("Ethan", "Plunkett",  email = "plunkett@umass.edu", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-4405-2251")),

NEWS.md

@@ -1,3 +1,15 @@
+# BirdFlowR 0.1.0.9043
+2023-12-15
+
+More tests and cleaner message handling.
+Users should be unaffected, but might see fewer messages if `birdflow_options("verbose")` is `TRUE`.
+
+* New test for `build_collection_index()`
+* New internal `bf_msg()` now used for messages from BirdFlowR functions.
+* New internal `bf_suppress_msg()` to wrap calls to other packages so that 
+  their messages are suppressed when verbose is false.
+
+
 # BirdFlowR 0.1.0.9042
 2023-12-14
 

R/animate_movement_vectors.R

@@ -71,13 +71,13 @@ animate_movement_vectors <- function(bf, ...) {
   }
 
   # Create data frame with movement vectors for all timesteps
-  cat("Creating vector fields\n\t")
+  bf_msg("Creating vector fields\n\t")
   d <- vector(mode = "list", length = length(transitions))
   for (i in seq_len(length(timesteps) - 1)) {
-    cat(".")
+    bf_msg(".")
     d[[i]] <- calc_movement_vectors(bf, timesteps[i], direction)
   }
-  cat("\n")
+  bf_msg("\n")
 
   d <- do.call(rbind, d)
 

R/bf_msg.R

@@ -0,0 +1,59 @@
+#' Internal function to send a message from within BirdFlow functions
+#'
+#' It checks to see if BirdFlowR is in verbose mode
+#' (`birdflow_options("verbose"`) and if so pastes it's arguments together
+#' and  prints the result with  `cat()`.
+#' In the future it might be updated to use `message()`
+#'
+#' @param ... Text that will be pasted together to make a message.
+#' @param sep (optional) separator between text elements in `...`
+#' defaults to no separation.
+#'
+#' @return Nothing is returned if verbose is TRUE the message is printed.
+#'
+#' @keywords internal
+#' @seealso [birdflow_options()] for changing verbosity.
+bf_msg <- function(..., sep = "") {
+  m <- paste(..., sep = sep)
+  if (birdflow_options("verbose")) {
+    cat(m)
+  }
+}
+
+
+
+#' Conditionally suppress messages from expressions in BirdFlowR code
+#'
+#' This internal functions is used to suppress messages thrown
+#' by functions called in BirdFlowR code if `birdflow_options("verbose")`
+#' is `FALSE`.
+#'
+#' @param exp R code that might throw a message (originating outside of
+#' pkg{BirdFlowR}.
+#' @keywords internal
+#' @seealso [preprocess_species()] uses this when calling \pkg{ebirdst}
+#' functions that display messages.
+#' When BirdFlowR functions generate messages they should use [bf_msg()] so that
+#' `birdflow_options("verbose")` is honored.
+#' @examples
+#' \dontrun{
+#' # bf_suppress_msg isn't exported so can't be run in examples
+#' # in internal code or after  devtools::load_all() example will work
+#'    ob <- birdflow_options("verbose")
+#'    birdflow_options(verbose = FALSE)
+#'    bf_suppress_msg( message("hi" ))
+#'    birdflow_options(verbose = TRUE)
+#'    bf_suppress_msg( message("hi" ))
+#'    birdflow_options(ob)
+#'  }
+#'
+bf_suppress_msg <- function(exp) {
+  verbose <- birdflow_options("verbose")
+  withCallingHandlers(
+    message = function(m) {
+      if (!verbose)
+        tryInvokeRestart("muffleMessage")
+    },
+    exp
+  )
+}

R/build_collection_index.R

@@ -22,7 +22,7 @@
 #'
 build_collection_index <- function(dir, collection_url) {
 
-  verbose <- birdflow_options("verbose")
+
   index_path <- file.path(dir, "index.Rds")
   index_md5_path <- file.path(dir, "index_md5.txt")
 
@@ -31,9 +31,9 @@ build_collection_index <- function(dir, collection_url) {
             "file", "release_date", "md5", "version", "size")
   species_cols <- c("species_code", "scientific_name", "common_name")
 
-   # List model files in directory
+  # List model files in directory
   files <- list.files(dir, pattern = paste0("^.*\\.", model_extension, "$"),
-                  ignore.case = TRUE)
+                      ignore.case = TRUE)
   files <- files[!tolower(files) %in% "index.rds"]
 
   if (length(files) == 0)
@@ -53,7 +53,7 @@ build_collection_index <- function(dir, collection_url) {
                            drop = FALSE]
     old_cols <- colnames(old_index)
     if (setequal(old_cols, cols) && all(old_cols == cols) &&
-       any(old_index$file %in% files)) {
+        any(old_index$file %in% files)) {
       if (all(files %in% old_index$file)) {
         new_index <- old_index
       } else {
@@ -76,8 +76,7 @@ build_collection_index <- function(dir, collection_url) {
     md5 <- as.character(tools::md5sum(f))
 
     if (is.na(index$md5[i]) || index$md5[i] != md5) { # if new or changed model
-      if (verbose)
-        cat("Reading metadata for ", index$model[i], "\n", sep = "")
+      bf_msg("Reading metadata for ", index$model[i], "\n")
       index$md5[i] <- md5
       bf <- readRDS(f)
       if (!inherits(bf, "BirdFlow")) {
@@ -109,9 +108,11 @@ build_collection_index <- function(dir, collection_url) {
   # Download logo
   logo_file <-   file.path(dir, "logo.png")
   if (!file.exists(logo_file)) {
-    utils::download.file(
+
+  utils::download.file(
       "https://birdflow-science.github.io/BirdFlowR/logo.png",
-      destfile = logo_file, method = "wget")
+      destfile = logo_file, method = "libcurl", mode = "wb",
+      quiet = !birdflow_options("verbose"))
   }
   # Save index.htm
   model <- index$model[1]
@@ -135,11 +136,13 @@ build_collection_index <- function(dir, collection_url) {
   index$report_exists <- file.exists(
     file.path(dir, paste0(index$model, ".html")))
 
-  rmarkdown::render(
-    input = rmd_file,
-    output_file = file.path(dir, "index.html"),
-    params = list(index = index, collection_url = collection_url))
-
+  suppressMessages({
+    rmarkdown::render(
+      input = rmd_file,
+      output_file = file.path(dir, "index.html"),
+      params = list(index = index, collection_url = collection_url),
+      quiet = !birdflow_options("verbose"))
+  })
   file.remove(rmd_file)
 
   # Write separate index.md5 file

R/determine_resolution.R

@@ -57,9 +57,6 @@ determine_resolution <- function(sp_path,
                                  download_species,
                                  project_method) {
 
-
-
-  verbose <- birdflow_options("verbose")
   max_param_per_gb <- birdflow_options("max_param_per_gpu_gb")
 
   if (!is.null(res)) {
@@ -72,15 +69,13 @@ determine_resolution <- function(sp_path,
               !is.na(gpu_ram),
               gpu_ram > 0)
     max_params <- max_param_per_gb * gpu_ram
-    if (verbose)
-      cat("Setting max_params to ", max_params, " anticipating ",
+    bf_msg("Setting max_params to ", max_params, " anticipating ",
           gpu_ram, " GB of GPU ram.\n")
   }
 
-  if (verbose)
-    cat("Calculating resolution\n")
   # Load low res abundance data and calculate total areas birds occupy at any
   # time (active_sq_m)
+  bf_msg("Calculating resolution\n")
   if (ebirdst_pkg_ver() < "3.2022.0") {
   abunds <- ebirdst::load_raster("abundance",
                                  path = sp_path,
@@ -106,17 +101,18 @@ determine_resolution <- function(sp_path,
     mask[is.na(mask)] <- FALSE
     abunds <- terra::mask(abunds, clip2)
 
-    if (verbose) {
-      # Calculate percent of density lost
-      # will print after printing the resolved resolution
-      sa <- sum(abunds)
-      csa <- terra::mask(sa, clip2)
-      tot_density <- sum(terra::values(sa), na.rm = TRUE)
-      clipped_density <- sum(terra::values(csa), na.rm = TRUE)
-      pct_lost <-
-        round((tot_density - clipped_density) / tot_density * 100, 2)
-      rm(sa, csa, tot_density, clipped_density)
-    }
+
+    # Calculate percent of density lost
+    # it is printed after printing the resolved resolution
+    sa <- sum(abunds)
+    csa <- terra::mask(sa, clip2)
+    tot_density <- sum(terra::values(sa), na.rm = TRUE)
+    clipped_density <- sum(terra::values(csa), na.rm = TRUE)
+    pct_lost <-
+      round((tot_density - clipped_density) / tot_density * 100, 2)
+    rm(sa, csa, tot_density, clipped_density)
+
+
     rm(clip2)
   } # end clip
 
@@ -145,10 +141,8 @@ determine_resolution <- function(sp_path,
     res <-  o$minimum
     res_m <- 1000 * res
 
-    if (verbose) {
-      cat("  Attempt ", i, " at setting resolution\n")
-      cat("  (", round(res, 3), "km chosen)\n", sep = "")
-    }
+    bf_msg("  Attempt ", i, " at setting resolution\n",
+           "  (", round(res, 3), "km chosen)\n")
 
     # Trial transformation
     initial_res <- mean(res(abunds))
@@ -172,43 +166,37 @@ determine_resolution <- function(sp_path,
     # Evaluating on actual max_params
     #  - not target_params which is slightly lower
     pct_of_target <- a_stats$n_params / max_params * 100
-    if (verbose)
-      cat("  ", round(pct_of_target, 2), "% of target (estimate).\n")
+    bf_msg("  ", round(pct_of_target, 2), "% of target (estimate).\n")
 
     if (pct_of_target <= 100 && pct_of_target > 90) {
-      if (verbose)
-        cat(" success\n")
+      bf_msg(" success\n")
       break
     } else {
       # Try again (up to 10 times)
-      if (verbose)
-        cat("  trying again\n")
+      bf_msg("  trying again\n")
     }
   } # end resolution trials
 
   if (pct_of_target > 100 || pct_of_target < 90)
-    cat("  Failed to find a resolution that resulted in > 90% and < 100 % of",
-        "the target parameters.\n")
+    warning("  Failed to find a resolution that resulted in > 90% and < 100 %",
+            " of the target parameters.\n")
 
   # Round
   breaks <-  c(-Inf, 2.5,  5,  300, 600, Inf)  # in km
   precision <- c(0.1,  .5,  1,    5,  10)  # in km
   tp <- precision[findInterval(res, breaks)] # target precision
   res <- ceiling(res / tp)  * tp
-  if (verbose)
-    cat("Rounded to", res, "km final resolution.\n")
+  bf_msg("Rounded to", res, "km final resolution.\n")
 
-  if (!is.null(clip) && verbose) {
-    cat("Clipping removed ", format(pct_lost, nsmall = 2),
-        "% of the total density\n", sep = "")
-    rm(pct_lost)
+  if (!is.null(clip)) {
+    bf_msg("Clipping removed ", format(pct_lost, nsmall = 2),
+        "% of the total density\n")
   }
 
   # With example date force resolution to be at least 30
   if (download_species %in% c("example_data", "yebsap-example") && res < 30) {
-    if (verbose)
-      cat("Resolution forced to 30 for example data,",
-          "which only has low resolution images\n")
+    bf_msg("Resolution forced to 30 for example data,",
+           "which only has low resolution images\n")
     res <- 30
   }
 

R/export_birdflow.R

@@ -24,9 +24,7 @@ export_birdflow <- function(bf, file = NULL,
       "If file is not NULL or a directory (ending in a slash) it should end",
          'in ".hdf5" or ".Rds" consistent with the format argument.'))
 
-  if (birdflow_options("verbose"))
-    cat("Exporting BirdFlow model for", species(bf), "to:\n\t",
-        file, "\n")
+  bf_msg("Exporting BirdFlow model for", species(bf), "to:\n\t", file, "\n")
 
 
   if (file.exists(file) && overwrite) {

R/export_rasters.R

@@ -199,10 +199,6 @@ export_rasters <- function(bf,
   text <- as.character(crs(r))
   writeLines(text, file.path(dir, "crs.txt"))
 
-  if (birdflow_options("verbose")) {
-    n <- length(list.files(dir))
-    cat("Wrote ", n, "files to", dir, "\n")
-  }
-
+  bf_msg("Wrote ", length(list.files(dir)), "files to", dir, "\n")
 
 }  # end function

R/fix_dead_ends.R

@@ -10,7 +10,6 @@
 #' @keywords internal
 fix_dead_ends <- function(bf, max_attempts = 100) {
 
-  verbose <- birdflow_options("verbose")
   fix_stats <- data.frame(step = 0:max_attempts, pct_lost = NA_real_,
                           n_dead_ends = NA_integer_)
 
@@ -36,11 +35,10 @@ fix_dead_ends <- function(bf, max_attempts = 100) {
     msum <- sum_marginals(bf)
     fix_stats$pct_lost[i] <- (initial_sum - msum) / initial_sum * 100
     fix_stats$n_dead_ends[i] <- nrow(de)
-    if (verbose)
-      cat("Step ", i - 1, " of ", max_attempts, " ",
-          nrow(de), " dead ends ",
-          fix_stats$pct_lost[i], "% density lost\n"
-          )
+
+    bf_msg("Step ", i - 1, " of ", max_attempts, " ",  nrow(de), " dead ends ",
+          fix_stats$pct_lost[i], "% density lost\n")
+
     if (nrow(de) == 0) {
       # If we've fixed it
       fix_stats <- fix_stats[1:i, ]

R/load_collection_index.R

@@ -46,8 +46,7 @@ load_collection_index <-
   }
 
   if (!up_to_date) {
-    if (birdflow_options("verbose"))
-      cat("Downloading collection index\n")
+    bf_msg("Downloading collection index\n")
     dir.create(dirname(local_index), recursive = TRUE, showWarnings = FALSE)
     utils::download.file(index_url, local_index, mode = "wb")
     make_cache_readme(collection_url)

R/load_model.R

@@ -30,7 +30,6 @@ load_model <- function(model, update = TRUE,
 
 
   collection_url <- gsub("/*$", "/", collection_url) # force trailing slash
-  verbose <- birdflow_options("verbose")
 
   stopifnot(!is.null(model), !is.na(model), is.character(model),
             length(model) == 1)
@@ -56,10 +55,9 @@ load_model <- function(model, update = TRUE,
   }
 
   if (update && (is.na(up_to_date) || !up_to_date)) {
-    if (verbose) {
-      cat("Downloading ", model, "\n\tFrom:", remote_url, "\n\tTo:",
-          local_path, "\n", sep = "")
-    }
+    bf_msg("Downloading ", model, "\n\tFrom:", remote_url, "\n\tTo:",
+           local_path, "\n", sep = "")
+
     utils::download.file(remote_url, local_path, quiet = TRUE, mode = "wb")
     make_cache_readme(collection_url)
   }