diff --git a/DESCRIPTION b/DESCRIPTION index 97efb53a..afb5e5ea 100644 --- a/DESCRIPTION +++ b/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")), diff --git a/NEWS.md b/NEWS.md index 03411a89..2d36ee04 100644 --- a/NEWS.md +++ b/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 diff --git a/R/animate_routes.R b/R/animate_routes.R index 97421e08..b4d72931 100644 --- a/R/animate_routes.R +++ b/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, diff --git a/R/plot_distr.R b/R/plot_distr.R index 773989a1..2fba03ce 100644 --- a/R/plot_distr.R +++ b/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,6 +214,11 @@ 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, @@ -209,26 +226,36 @@ plot_distr <- function(distr, 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 diff --git a/R/plot_flux.R b/R/plot_flux.R index 7165b0d4..be760957 100644 --- a/R/plot_flux.R +++ b/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 " " 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 diff --git a/R/plot_routes.R b/R/plot_routes.R index d7837973..9e925abf 100644 --- a/R/plot_routes.R +++ b/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 diff --git a/R/preprocess_species.R b/R/preprocess_species.R index 811b4107..acd37cbe 100644 --- a/R/preprocess_species.R +++ b/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) diff --git a/R/process_rasters.R b/R/process_rasters.R index 7b5071b0..8f208ff0 100644 --- a/R/process_rasters.R +++ b/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) diff --git a/R/suppress_specific_warnings.R b/R/suppress_specific_warnings.R new file mode 100644 index 00000000..1a62d74f --- /dev/null +++ b/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) + +} diff --git a/data-raw/callaghan_abundance.R b/data-raw/callaghan_abundance.R index cf844e5c..62154d1f 100644 --- a/data-raw/callaghan_abundance.R +++ b/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 diff --git a/man/animate_distr.Rd b/man/animate_distr.Rd index a8fecfed..5fea9aa4 100644 --- a/man/animate_distr.Rd +++ b/man/animate_distr.Rd @@ -59,6 +59,11 @@ landscape. These are cells that are always masked. Only relevant when \code{show_mask = TRUE}.} \item{\code{value_label}}{The label used for the values in the distribution. Defaults to "Density"} + \item{\code{transform}}{A transformation to apply to the color scaling. Recommended +\code{"identity"}, and \code{"sqrt"}. If \code{"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 \code{\link[ggplot2:scale_gradient]{ggplot2::scale_color_gradientn()}}.} }} } \value{ diff --git a/man/animate_flux.Rd b/man/animate_flux.Rd index 68ee7fdf..37f58534 100644 --- a/man/animate_flux.Rd +++ b/man/animate_flux.Rd @@ -35,6 +35,12 @@ plotting the coastline.} \item{\code{gradient_colors}}{The colors palette used to represent the flux intensity.} \item{\code{value_label}}{The label for the flux values.} + \item{\code{transform}}{A transformation to apply to the color scaling. +\code{"identity"}, and \code{"sqrt"} are recommended. +If \code{"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 \code{\link[ggplot2:scale_gradient]{ggplot2::scale_color_gradientn()}}.} }} } \value{ diff --git a/man/animate_routes.Rd b/man/animate_routes.Rd index 7c2c3c7a..560e64fa 100644 --- a/man/animate_routes.Rd +++ b/man/animate_routes.Rd @@ -57,12 +57,12 @@ from within \code{animate_routes()} where it could not be suppressed." 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, diff --git a/man/plot_distr.Rd b/man/plot_distr.Rd index 5afeaee6..253f00bf 100644 --- a/man/plot_distr.Rd +++ b/man/plot_distr.Rd @@ -18,7 +18,8 @@ plot_distr( active_cell_color = rgb(1, 1, 1, 0.3), inactive_cell_color = rgb(0, 0, 0, 0.2), title = species(bf), - value_label = "Density" + value_label = "Density", + transform = "identity" ) } \arguments{ @@ -80,6 +81,12 @@ species (\code{species(bf)}).} \item{value_label}{The label used for the values in the distribution. Defaults to "Density"} + +\item{transform}{A transformation to apply to the color scaling. Recommended +\code{"identity"}, and \code{"sqrt"}. If \code{"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 \code{\link[ggplot2:scale_gradient]{ggplot2::scale_color_gradientn()}}.} } \value{ \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} object. Use \code{print()} to render it. diff --git a/man/plot_flux.Rd b/man/plot_flux.Rd index 633395fb..9f4490a5 100644 --- a/man/plot_flux.Rd +++ b/man/plot_flux.Rd @@ -14,7 +14,8 @@ plot_flux( coast_color = gray(0.5), gradient_colors = NULL, title = species(bf), - value_label = "Flux" + value_label = "Flux", + transform = "identity" ) } \arguments{ @@ -49,6 +50,13 @@ intensity.} \item{title}{The plot title} \item{value_label}{The label for the flux values.} + +\item{transform}{A transformation to apply to the color scaling. +\code{"identity"}, and \code{"sqrt"} are recommended. +If \code{"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 \code{\link[ggplot2:scale_gradient]{ggplot2::scale_color_gradientn()}}.} } \value{ \code{plot_flux} returns a \strong{ggplot2} object. It can be displayed with diff --git a/man/suppress_specific_warnings.Rd b/man/suppress_specific_warnings.Rd new file mode 100644 index 00000000..38bcefec --- /dev/null +++ b/man/suppress_specific_warnings.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/suppress_specific_warnings.R +\name{suppress_specific_warnings} +\alias{suppress_specific_warnings} +\title{Suppress warnings that match one or more regular expressions} +\usage{ +suppress_specific_warnings(x, patterns = NULL) +} +\arguments{ +\item{x}{An expression.} + +\item{patterns}{One or more patterns to check warning messages against.} +} +\value{ +Possibly output from \code{x} +} +\description{ +\code{suppress_specific_warnings()} will suppress warnings that match regular +expression patterns that are supplied via +the \code{patterns} argument, without suppressing warnings that don't match the +patterns. +} +\keyword{internal} diff --git a/tests/testthat/helper-get_americas.R b/tests/testthat/helper-get_americas.R index 5f5b1c98..117eefb7 100644 --- a/tests/testthat/helper-get_americas.R +++ b/tests/testthat/helper-get_americas.R @@ -1,17 +1,18 @@ # Function to return americas - used for setting up "big run" clipping boundary # here so we can reproduce the clipping issue in that run. -get_americas <- function(clip_to_mainland_us = FALSE, include_hawaii = FALSE){ +get_americas <- function(clip_to_mainland_us = FALSE, include_hawaii = FALSE) { earth <- rnaturalearth::ne_countries(scale = 50) americas <- earth[grep("America", earth$continent), , drop = FALSE] - if(clip_to_mainland_us){ - extent <- c(ymax = 50, ymin = 25, xmin = -130, xmax = -55 ) + if (clip_to_mainland_us) { + extent <- c(ymax = 50, ymin = 25, xmin = -130, xmax = -55) americas <- sf::st_crop(americas, extent) americas <- americas[americas$name == "United States", , drop = FALSE] } # Drop Hawaii - if(!include_hawaii){ - clip <- sf::st_bbox(c(ymax = 25, ymin = 15, xmin = -165, xmax = -150 )) |> sf::st_as_sfc() + if (!include_hawaii) { + clip <- sf::st_bbox(c(ymax = 25, ymin = 15, xmin = -165, xmax = -150)) |> + sf::st_as_sfc() sf::st_crs(clip) <- "EPSG:4326" americas <- sf::st_difference(americas, clip) } diff --git a/tests/testthat/test-preprocess_species.R b/tests/testthat/test-preprocess_species.R index c33ef384..cbb04ca8 100644 --- a/tests/testthat/test-preprocess_species.R +++ b/tests/testthat/test-preprocess_species.R @@ -253,10 +253,10 @@ test_that("preprocess_species() works with clip and crs", { PARAMETER["Latitude of natural origin",', lat0, ', ANGLEUNIT["Degree",0.0174532925199433], ID["EPSG",8801]], - PARAMETER["Longitude of natural origin",', lon0,', + PARAMETER["Longitude of natural origin",', lon0, ', ANGLEUNIT["Degree",0.0174532925199433], ID["EPSG",8802]], - PARAMETER["False easting",', false_easting,', + PARAMETER["False easting",', false_easting, ', LENGTHUNIT["metre",1], ID["EPSG",8806]], PARAMETER["False northing",', false_northing, ', @@ -285,13 +285,10 @@ test_that("preprocess_species() works with clip and crs", { r <- rasterize_distr(get_distr(bf, 20), bf) - if(FALSE) + if (FALSE) plot(r) # expect uppper right corner to be NA expect_true(is.na(r[1, ncol(r)])) }) - - -