From bb14c95501c7513a2ac90a1c135544c05c47eb57 Mon Sep 17 00:00:00 2001 From: fawda123 Date: Sat, 28 Sep 2024 11:02:58 -0400 Subject: [PATCH] add listout arg to show_fibmatmap --- R/show_fibmatmap.R | 42 ++++++++++++++++++++-------- man/show_fibmatmap.Rd | 7 +++-- tests/testthat/test-show_fibmatmap.R | 8 +++++- 3 files changed, 43 insertions(+), 14 deletions(-) diff --git a/R/show_fibmatmap.R b/R/show_fibmatmap.R index b82a4ed3..cf80bb95 100644 --- a/R/show_fibmatmap.R +++ b/R/show_fibmatmap.R @@ -10,8 +10,9 @@ #' @param precipdata input data frame as returned by \code{\link{read_importrain}}. columns should be: station, date (yyyy-mm-dd), rain (in inches). The object \code{\link{catchprecip}} has this data from 1995-2023 for select Enterococcus stations. If \code{NULL}, defaults to \code{\link{catchprecip}}. #' @param temporal_window numeric; required if \code{subset_wetdry} is not \code{"all"}. number of days precipitation should be summed over (1 = day of sample only; 2 = day of sample + day before; etc.) #' @param wet_threshold numeric; required if \code{subset_wetdry} is not \code{"all"}. inches accumulated through the defined temporal window, above which a sample should be defined as being from a 'wet' time period +#' @param listout logical to return a list of simple feature objects for the data used in the \code{leaflet} map, default \code{FALSE} #' -#' @return A \code{leaflet} map for the selected year and area showing station matrix scores. Bay segment scores are also shown if the input data are not from EPCHC. +#' @return A \code{leaflet} map for the selected year and area showing station matrix scores if \code{listout = FALSE} (default). Bay segment scores are also shown if the input data are not from EPCHC. A list of simple feature objects is returned if \code{listout = TRUE}. #' #' @details Placing the mouse cursor over an item on the map will reveal additional information about a segment or station. #' @@ -33,7 +34,7 @@ #' areasel = c("Hillsborough River", "Alafia River")) show_fibmatmap <- function(fibdata, yrsel, areasel, indic, threshold = NULL, lagyr = 3, subset_wetdry = c("all", "wet", "dry"), precipdata = NULL, - temporal_window = NULL, wet_threshold = NULL){ + temporal_window = NULL, wet_threshold = NULL, listout = FALSE){ # get categories cols <- c('#2DC938', '#E9C318', '#EE7600', '#CC3231', '#800080') @@ -94,13 +95,40 @@ show_fibmatmap <- function(fibdata, yrsel, areasel, indic, threshold = NULL, subset_wetdry = subset_wetdry, precipdata = precipdata, temporal_window = temporal_window, wet_threshold = wet_threshold) + tomapseg <- NULL + } # create custom icon list for fib matrix categories icons <- util_fibicons('fibmat') - # legend as HTML string + # FIB levels levs <- util_fiblevs() + + # subset year, remove NA cat, add labels + tomapsta <- tomapsta %>% + dplyr::filter(!is.na(cat)) %>% + dplyr::filter(yr == !!yrsel) %>% + sf::st_as_sf(coords = c("Longitude", "Latitude"), crs = 4326, remove = FALSE) %>% + dplyr::mutate( + cat = factor(cat, levels = levs$fibmatlev), + lab = paste0('Station Number: ', grp, '
Category: ', cat) + ) + + # return data instead of leaflet + if(listout){ + + out <- list( + icons = icons, + tomapsta = tomapsta, + tomapseg = tomapseg + ) + + return(out) + + } + + # legend leg <- tibble::tibble( src = paste0('https://github.com/tbep-tech/tbeptools/blob/master/inst/', basename(sapply(icons, `[[`, 1)), '?raw=true'), brk = levs$fibmatlbs @@ -113,14 +141,6 @@ show_fibmatmap <- function(fibdata, yrsel, areasel, indic, threshold = NULL, paste(collapse = '
') %>% paste0('FIB matrix
categories
', .) - tomapsta <- tomapsta %>% - dplyr::filter(!is.na(cat)) %>% - dplyr::filter(yr == !!yrsel) %>% - sf::st_as_sf(coords = c("Longitude", "Latitude"), crs = 4326, remove = FALSE) %>% - dplyr::mutate( - cat = factor(cat, levels = levs$fibmatlev), - lab = paste0('Station Number: ', grp, '
Category: ', cat) - ) # create map out <- util_map(tomapsta) %>% diff --git a/man/show_fibmatmap.Rd b/man/show_fibmatmap.Rd index 64053763..f6a380b7 100644 --- a/man/show_fibmatmap.Rd +++ b/man/show_fibmatmap.Rd @@ -14,7 +14,8 @@ show_fibmatmap( subset_wetdry = c("all", "wet", "dry"), precipdata = NULL, temporal_window = NULL, - wet_threshold = NULL + wet_threshold = NULL, + listout = FALSE ) } \arguments{ @@ -37,9 +38,11 @@ show_fibmatmap( \item{temporal_window}{numeric; required if \code{subset_wetdry} is not \code{"all"}. number of days precipitation should be summed over (1 = day of sample only; 2 = day of sample + day before; etc.)} \item{wet_threshold}{numeric; required if \code{subset_wetdry} is not \code{"all"}. inches accumulated through the defined temporal window, above which a sample should be defined as being from a 'wet' time period} + +\item{listout}{logical to return a list of simple feature objects for the data used in the \code{leaflet} map, default \code{FALSE}} } \value{ -A \code{leaflet} map for the selected year and area showing station matrix scores. Bay segment scores are also shown if the input data are not from EPCHC. +A \code{leaflet} map for the selected year and area showing station matrix scores if \code{listout = FALSE} (default). Bay segment scores are also shown if the input data are not from EPCHC. A list of simple feature objects is returned if \code{listout = TRUE}. } \description{ Map Fecal Indicator Bacteria matrix results by year diff --git a/tests/testthat/test-show_fibmatmap.R b/tests/testthat/test-show_fibmatmap.R index 89e087bf..f1712f47 100644 --- a/tests/testthat/test-show_fibmatmap.R +++ b/tests/testthat/test-show_fibmatmap.R @@ -3,6 +3,13 @@ test_that("show_fibmatmap returns a leaflet map for non-EPCHC", { expect_s3_class(map, "leaflet") }) +test_that("show_fibmatmap returns list of data used if listout is TRUE", { + dat <- expect_warning(show_fibmatmap(enterodata, yrsel = 2020, areasel = c('OTB', 'HB'), indic = 'entero', + listout = T)) + expect_equal(class(dat), "list") + expect_equal(names(dat), c('icons', 'tomapsta', 'tomapseg')) +}) + test_that("show_fibmatmap returns a leaflet map for EPCHC", { map <- expect_warning(show_fibmatmap(fibdata, yrsel = 2020, areasel = c('Hillsborough River'), indic = 'fcolif')) expect_s3_class(map, "leaflet") @@ -16,7 +23,6 @@ test_that("show_fibmatmap errors on invalid areasel for EPCHC data", { ) }) -# Test 5: Handles wet/dry sample subset with correct parameters test_that("show_fibmatmap subsets data for wet or dry samples", { map_wet <- expect_warning(show_fibmatmap(enterodata, yrsel = 2020, areasel = c('OTB', 'HB'), indic = 'entero', subset_wetdry = "wet", temporal_window = 2, wet_threshold = 0.3)) map_dry <- expect_warning(show_fibmatmap(enterodata, yrsel = 2020, areasel = c('OTB', 'HB'), indic = 'entero', subset_wetdry = "dry", temporal_window = 2, wet_threshold = 0.3))