Merge pull request #187 from birdflow-science/186-add-plot-transforma…

…tion-options

186 add plot transformation options

DESCRIPTION

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

NEWS.md

@@ -1,4 +1,19 @@
 
+
+# BirdFlowR 0.1.0.9061
+2024-06-05 
+
+* Add `suppress_specific_warnings()` internal function.
+* Update `plot_distr()`, `plot_route()`, and `plot_flux()` 
+so that they work with BirdFlow models in which the extent does not overlap 
+the coast. `bcrfin`, Brown-capped Rosy-Finch is one example. 
+* Add `transform` argument to `plot_flux()` and `plot_distr()` to allow 
+log (`"log"`) and square route (`"sqrt"`) transformations prior to applying 
+the color scale.  These allow differentiating the smaller differences better.
+I think the square route transformation might be the way to go.
+
+
+
 # BirdFlowR 0.1.0.9060
 2024-05-15 
 

R/animate_routes.R

@@ -21,12 +21,12 @@
 #'
 #'
 #' bf <- BirdFlowModels::amewoo
-#' rts <- route_migration(bf, 10)
+#' rts <- route(bf, 10,  season = "prebreeding")
 #' anim <- animate_routes(rts, bf)
 #'
 #' \dontrun{
 #'   # example render
-#'   timesteps <- unique(rts$points$timestep)
+#'   timesteps <- unique(rts$timestep)
 #'   gif <- gganimate::animate(anim,
 #'                             device = "ragg_png", # is fast and pretty
 #'                             width = 7, height = 6,

R/plot_distr.R

@@ -86,8 +86,11 @@
 #'   species (`species(bf)`).
 #' @param value_label The label used for the values in the distribution.
 #'   Defaults to "Density"
-#'
-#'
+#' @param transform A transformation to apply to the color scaling. Recommended
+#' `"identity"`, and `"sqrt"`.  If `"log"` is used zeros will be replaced with
+#' 1/2 the smallest non-zero value prior to transforming.
+#' mapping to the color gradient. Legend will still reflect the original values.
+#' Passed to [ggplot2::scale_color_gradientn()].
 #' @return [ggplot2::ggplot()] object.  Use `print()` to render it.
 #' @export
 #' @importFrom grDevices gray grey
@@ -112,7 +115,8 @@ plot_distr <- function(distr,
                        active_cell_color = rgb(1, 1, 1, .3),
                        inactive_cell_color = rgb(0, 0, 0, .2),
                        title = species(bf),
-                       value_label = "Density") {
+                       value_label = "Density",
+                       transform = "identity") {
 
   if (!is.null(limits) && dynamic_scale) {
     stop("Do not set dynamic_scale to TRUE while also setting limits.")
@@ -140,6 +144,15 @@ plot_distr <- function(distr,
     }
   }
 
+  if (transform == "log") {
+
+    min_non_zero <- min(distr[!distr == 0], na.rm = TRUE)
+    if (min_non_zero < 0)
+      stop("Can't log distribution with negative values.")
+
+    distr[distr == 0] <- min_non_zero / 2
+
+  }
 
   if (is.null(limits)) {
     limits <- range(distr, na.rm = TRUE)
@@ -192,7 +205,6 @@ plot_distr <- function(distr,
     order_labeller  <-  ggplot2::as_labeller(order_to_label)
   }
 
-  coast <- get_coastline(bf)
 
   if (is.null(gradient_colors)) {
     # Same as ebirdst::abundance_palette(10, season = "weekly")
@@ -202,33 +214,48 @@ plot_distr <- function(distr,
       c("#EDDEA5", "#FCCE25", "#FBA238", "#EE7B51", "#DA596A", "#BF3984",
         "#9D189D", "#7401A8", "#48039F", "#0D0887")
   }
+
+
+
+
+
   p <-
     ggplot2::ggplot(r, ggplot2::aes(x = .data$x,
                                     y = .data$y,
                                     fill = .data[[value_label]])) +
     ggplot2::geom_raster()
 
 
+
   if (dynamic_scale) {
     p <- p +  ggplot2::scale_fill_gradientn(colors = gradient_colors,
                                             na.value = active_cell_color,
                                             limits = limits,
                                             breaks = c(0, 1),
-                                            labels = c("Min.", "Max."))
+                                            labels = c("Min.", "Max."),
+                                            transform = transform)
   } else {
     p <- p + ggplot2::scale_fill_gradientn(colors = gradient_colors,
                                            na.value = active_cell_color,
-                                           limits = limits)
+                                           limits = limits,
+                                           transform = transform)
   }
 
   if (!is.null(coast_color) && !is.null(coast_linewidth)) {
 
-    p  <- p +
-      ggplot2::geom_sf(data = coast,
-                       inherit.aes = FALSE,
-                       linewidth = coast_linewidth,
-                       color = coast_color)
+    suppress_specific_warnings({
+      coast <- get_coastline(bf)
+    }, "No objects within extent. Returning empty sf object.")
 
+
+    if (nrow(coast) > 0) {
+
+      p  <- p +
+        ggplot2::geom_sf(data = coast,
+                         inherit.aes = FALSE,
+                         linewidth = coast_linewidth,
+                         color = coast_color)
+    }
   }
 
   # coord_sf is required to adjust coordinates while using geom_sf
@@ -272,9 +299,9 @@ plot_distr <- function(distr,
 
     # Add it to the plot
     p <- p + ggplot2::annotation_raster(col_mask, xmin = xmin(bf),
-                               xmax = xmax(bf),
-                               ymin = ymin(bf),
-                               ymax = ymax(bf))
+                                        xmax = xmax(bf),
+                                        ymin = ymin(bf),
+                                        ymax = ymax(bf))
 
 
     # Move the new annotation layer to the first layer so it draws under others

R/plot_flux.R

@@ -22,6 +22,12 @@
 #' intensity.
 #' @param title The plot title
 #' @param value_label The label for the flux values.
+#' @param transform A transformation to apply to the color scaling.
+#' `"identity"`, and `"sqrt"` are recommended.
+#' If `"log"` is used zeros will be replaced with
+#' 1/2 the smallest non-zero value prior to transforming.
+#' Legend will still reflect the original values.
+#' Passed to [ggplot2::scale_color_gradientn()].
 #' @return `plot_flux` returns a **ggplot2** object.  It can be displayed with
 #' `print()`.
 #' @export
@@ -35,14 +41,30 @@ plot_flux <- function(flux,
                       coast_color = gray(0.5),
                       gradient_colors = NULL,
                       title = species(bf),
-                      value_label = "Flux") {
+                      value_label = "Flux",
+                      transform = "identity") {
 
   if (!is.null(limits) && dynamic_scale) {
     stop("Do not set dynamic_scale to TRUE while also setting limits.")
   }
 
+
   if (dynamic_scale) {
-    distr <- apply(distr, 2, function(x) x / max(x, na.rm = TRUE))
+
+    # Scale each transition 0 to 1
+    for (t in unique(flux$transition)) {
+      sv <- flux$transition == t
+      flux$flux[sv] <- range_rescale(flux$flux[sv])
+    }
+
+  }
+
+  if (transform == "log") {
+    min_non_zero <- min(flux$flux[!flux$flux == 0], na.rm = TRUE)
+    if (min_non_zero < 0)
+      stop("Can't log transflorm flux with negative values.")
+
+    flux$flux[flux$flux == 0] <- min_non_zero / 2
   }
 
   # Add "<Month> <mday>" labels as ordered factor
@@ -86,9 +108,9 @@ plot_flux <- function(flux,
       transitions <- transitions[subset]
     } else if (is.numeric(subset)) {
       if (anyNA(subset) ||
-         !all.equal(subset, floor(subset)) ||
-         any(subset < 1) ||
-         any(subset > length(transitions))) {
+          !all.equal(subset, floor(subset)) ||
+          any(subset < 1) ||
+          any(subset > length(transitions))) {
         stop("Numeric subset should contain only integer values between 1 and ",
              length(transitions), ".")
       }
@@ -113,7 +135,9 @@ plot_flux <- function(flux,
     ggplot2::ggplot(ggplot2::aes(x = .data$x, y = .data$y,
                                  fill = .data$flux)) +
     ggplot2::geom_raster() +
-    ggplot2::scale_fill_gradientn(colors = gradient_colors, name = value_label)
+    ggplot2::scale_fill_gradientn(colors = gradient_colors,
+                                  name = value_label,
+                                  transform = transform)
 
 
   # Add facet wrap and title
@@ -133,15 +157,18 @@ plot_flux <- function(flux,
   # Add coastline
   if (!is.null(coast_color) && !is.null(coast_linewidth)) {
 
-    coast <- get_coastline(bf)
+    suppress_specific_warnings({
+      coast <- get_coastline(bf)
+    }, "No objects within extent. Returning empty sf object.")
 
-    p  <- p +
-      ggplot2::geom_sf(data = coast,
-                       inherit.aes = FALSE,
-                       linewidth = coast_linewidth,
-                       color = coast_color)
+    if (nrow(coast) > 0) {
+      p  <- p +
+        ggplot2::geom_sf(data = coast,
+                         inherit.aes = FALSE,
+                         linewidth = coast_linewidth,
+                         color = coast_color)
+    }
   }
-
   # coord_sf is required to adjust coordinates while using geom_sf
   # Here we are preventing expanding the extent of the plot.
   # Setting the CRS is only necessary when the coastline isn't plotted because

R/plot_routes.R

@@ -181,8 +181,6 @@ plot_routes <- function(routes, bf, facet = FALSE, max_stay_len = NULL,
   rast$value[is.na(rast$value)] <- FALSE
   rast$value <- rast$value
 
-  # Coastline for this model
-  coast <- get_coastline(bf)
 
   #----------------------------------------------------------------------------#
   # Data summary
@@ -297,16 +295,29 @@ plot_routes <- function(routes, bf, facet = FALSE, max_stay_len = NULL,
                              max_size = dot_sizes[2],
                              breaks = stay_len_breaks,
                              name = "Stay Length",
-                             guide = ggplot2::guide_legend(order = 0)) +
+                             guide = ggplot2::guide_legend(order = 0))
 
-    # Plot coastal data
-    ggplot2::geom_sf(data = coast,
-                     inherit.aes = FALSE,
-                     linewidth = coast_linewidth,
-                     color = coast_color) +
+  # Plot coastal data
+  if (!is.null(coast_color) && !is.null(coast_linewidth)) {
 
-    # coord_sf is required to adjust coordinates while using geom_sf
-    # Here we are preventing expanding the extent of the plot.
+    # Coastline for this model
+    suppress_specific_warnings({
+      coast <- get_coastline(bf)
+    }, "No objects within extent. Returning empty sf object.")
+
+    if (nrow(coast) > 0) {
+
+      p <- p +
+        ggplot2::geom_sf(data = coast,
+                         inherit.aes = FALSE,
+                         linewidth = coast_linewidth,
+                         color = coast_color)
+    }
+  }
+
+  # coord_sf is required to adjust coordinates while using geom_sf
+  # Here we are preventing expanding the extent of the plot.
+  p  <- p +
     ggplot2::coord_sf(expand = FALSE) +
 
     # Add title and subtitle

R/preprocess_species.R

@@ -330,7 +330,7 @@ preprocess_species <- function(species = NULL,
   } else {
 
     # Handle objects of class crs (defined in sf)
-    if(inherits(crs, "crs"))
+    if (inherits(crs, "crs"))
       crs <- crs$wkt
 
     crs <- terra::crs(crs)

R/process_rasters.R

@@ -166,7 +166,7 @@ process_rasters <- function(res,
   bf_msg(" done.\n")
 
   # Clip data
-  if(!is.null(clip)){
+  if (!is.null(clip)) {
     abunds <- terra::mask(abunds, clip)
     abunds_uci <- terra::mask(abunds_uci, clip)
     abunds_lci <- terra::mask(abunds_lci, clip)

R/suppress_specific_warnings.R

@@ -0,0 +1,29 @@
+#' Suppress warnings that match one or more regular expressions
+#'
+#' `suppress_specific_warnings()` will suppress warnings that match regular
+#' expression patterns that are supplied via
+#' the `patterns` argument, without suppressing warnings that don't match the
+#' patterns.
+#'
+#' @keywords internal
+#' @param x An expression.
+#' @param patterns One or more patterns to check warning messages against.
+#'
+#' @return Possibly output from `x`
+#' @keywords internal
+suppress_specific_warnings <- function(x, patterns = NULL) {
+
+
+
+  any_match <- function(cnd, patterns) {
+    any(sapply(patterns, function(x) grepl(x, cnd)))
+  }
+
+  check_warning <- function(w) {
+    if (any_match(conditionMessage(w), patterns))
+      invokeRestart("muffleWarning")
+  }
+
+  withCallingHandlers(x, warning = check_warning)
+
+}

data-raw/callaghan_abundance.R

@@ -35,7 +35,8 @@ a$species_code <- t$species_code[mv]
 # Based on common name
 unmatched <- is.na(a$species_code)
 
-a$species_code[unmatched] <- t$species_code[match(a$common_name[unmatched], t$common_name)]
+a$species_code[unmatched] <- t$species_code[match(a$common_name[unmatched],
+                                                  t$common_name)]
 
 
 # Determine which ones are in the current eBird version