From 803d877637ef7518d81707a9a029dfae53da59e1 Mon Sep 17 00:00:00 2001 From: JoFrhwld Date: Tue, 26 Sep 2023 12:03:50 -0400 Subject: [PATCH 1/5] created safe version of get_isolines --- R/density_area.R | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/R/density_area.R b/R/density_area.R index 208be76..639a599 100644 --- a/R/density_area.R +++ b/R/density_area.R @@ -34,6 +34,23 @@ get_isolines<- function(x, return(isolines_df) } +get_isolines_safely <- function(...){ + emtpy_iso <- tibble::tibble(line = character(), + x = double(), + y = double(), + id = integer()) + + purrr::safely(get_isolines, + otherwise = empty_iso, + quiet = TRUE)(...)-> + iso_result + + if(!is.null(iso_result$error)){ + warning("There was a problem calculating probability isolines.") + } + + return(iso_result$result) +} #' Density polygons #' From 31cffbc92a91b35ee13e4ae73c9e6fde9c377011 Mon Sep 17 00:00:00 2001 From: JoFrhwld Date: Tue, 26 Sep 2023 12:23:09 -0400 Subject: [PATCH 2/5] trying to catch empty tibbles. Not working --- R/density_area.R | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/R/density_area.R b/R/density_area.R index 639a599..4f4dd4b 100644 --- a/R/density_area.R +++ b/R/density_area.R @@ -96,7 +96,7 @@ density_polygons <- function(x, repair = "unique", quiet = TRUE) - isolines <- get_isolines(x, y, probs, ...) + isolines <- get_isolines_safely(x, y, probs, ...) isolines |> dplyr::mutate( @@ -124,23 +124,30 @@ density_polygons <- function(x, return(iso_poly_df) } - iso_poly_df |> - dplyr::mutate( - polygon_id = paste(.data$line_id, .data$id, sep = "-") - ) |> - sfheaders::sf_polygon( - x = xname, - y = yname, - polygon_id = "polygon_id", - keep = T - ) |> - dplyr::select(-"polygon_id") |> - sf::st_sf() |> - dplyr::group_by( - .data$line_id, .data$prob - ) |> - dplyr::summarise() -> - iso_poly_st + if(nrow(iso_poly_df) == 0){ + iso_poly_df |> + mutate(geometry = st_sfc()) |> + st_sf() -> + iso_poly_st + }else{ + iso_poly_df |> + dplyr::mutate( + polygon_id = paste(.data$line_id, .data$id, sep = "-") + ) |> + sfheaders::sf_polygon( + x = xname, + y = yname, + polygon_id = "polygon_id", + keep = T + ) |> + dplyr::select(-"polygon_id") |> + sf::st_sf() |> + dplyr::group_by( + .data$line_id, .data$prob + ) |> + dplyr::summarise() -> + iso_poly_st + } if (as_list) { return(list(iso_poly_st)) From aec035ae1daf608ea42271f6aafc469f39be1dea Mon Sep 17 00:00:00 2001 From: JoFrhwld Date: Tue, 26 Sep 2023 14:56:50 -0400 Subject: [PATCH 3/5] safely handle errors within groups all the way down --- R/density_area.R | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/R/density_area.R b/R/density_area.R index 4f4dd4b..6c9b7d9 100644 --- a/R/density_area.R +++ b/R/density_area.R @@ -124,11 +124,8 @@ density_polygons <- function(x, return(iso_poly_df) } - if(nrow(iso_poly_df) == 0){ - iso_poly_df |> - mutate(geometry = st_sfc()) |> - st_sf() -> - iso_poly_st + if(nrow(iso_poly_df) < 4){ + iso_poly_st <- NULL }else{ iso_poly_df |> dplyr::mutate( @@ -192,23 +189,28 @@ density_area <- function(x, ) -> iso_poly_sf - iso_poly_sf |> - sf::st_sf() |> - dplyr::mutate( - area = sf::st_area(.data$geometry) - ) -> - area_poly - - if (!as_sf) { - area_poly |> - sf::st_drop_geometry() -> + if(!is.null(iso_poly_sf)){ + iso_poly_sf |> + sf::st_sf() |> + dplyr::mutate( + area = sf::st_area(.data$geometry) + ) -> area_poly + + if (!as_sf) { + area_poly |> + sf::st_drop_geometry() -> + area_poly + } + + }else{ + area_poly <- NULL } if (as_list) { area_poly <- list(area_poly) - } return(area_poly) + } From be6275121d540fa0dbcf580a498674bb926a52b7 Mon Sep 17 00:00:00 2001 From: JoFrhwld Date: Tue, 26 Sep 2023 14:57:12 -0400 Subject: [PATCH 4/5] Improve warning about groups that are too small --- R/density_area.R | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/R/density_area.R b/R/density_area.R index 6c9b7d9..2a7841b 100644 --- a/R/density_area.R +++ b/R/density_area.R @@ -35,10 +35,11 @@ get_isolines<- function(x, } get_isolines_safely <- function(...){ - emtpy_iso <- tibble::tibble(line = character(), - x = double(), - y = double(), - id = integer()) + + empty_iso <- tibble::tibble(line = NA_character_, + x = NA_real_, + y = NA_real_, + id = NA_integer_) purrr::safely(get_isolines, otherwise = empty_iso, @@ -46,7 +47,13 @@ get_isolines_safely <- function(...){ iso_result if(!is.null(iso_result$error)){ - warning("There was a problem calculating probability isolines.") + dots <- rlang::dots_list(...) + data_len <- length(dots$x) + warning( + glue::glue( + "There was a problem calculating probability isolines.\nℹ There were {data_len} values in the input." + ) + ) } return(iso_result$result) @@ -96,7 +103,7 @@ density_polygons <- function(x, repair = "unique", quiet = TRUE) - isolines <- get_isolines_safely(x, y, probs, ...) + isolines <- get_isolines_safely(x=x, y=y, probs=probs, ...) isolines |> dplyr::mutate( From 3311a39db9928092e38416d9dfe524ededb2a7ca Mon Sep 17 00:00:00 2001 From: JoFrhwld Date: Tue, 26 Sep 2023 15:15:30 -0400 Subject: [PATCH 5/5] better warning with {cli} --- DESCRIPTION | 1 + R/density_area.R | 7 +++---- usethis_hist.R | 1 + 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8a3ac28..13e11fc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,6 +16,7 @@ RoxygenNote: 7.2.3 URL: https://github.com/JoFrhwld/densityarea, https://jofrhwld.github.io/densityarea/ BugReports: https://github.com/JoFrhwld/densityarea/issues Imports: + cli, dplyr, ggdensity, isoband, diff --git a/R/density_area.R b/R/density_area.R index 2a7841b..a35290f 100644 --- a/R/density_area.R +++ b/R/density_area.R @@ -49,10 +49,9 @@ get_isolines_safely <- function(...){ if(!is.null(iso_result$error)){ dots <- rlang::dots_list(...) data_len <- length(dots$x) - warning( - glue::glue( - "There was a problem calculating probability isolines.\nℹ There were {data_len} values in the input." - ) + cli::cli_warn( + c("There was a problem calculating probability isolines.", + "i" = "There {?was/were} {data_len} x,y pair{?s} in the input.") ) } diff --git a/usethis_hist.R b/usethis_hist.R index e242ddc..e50b68c 100644 --- a/usethis_hist.R +++ b/usethis_hist.R @@ -57,6 +57,7 @@ usethis::use_package("sf") usethis::use_package("tidyr") usethis::use_package("sfheaders") usethis::use_package("vctrs") +usethis::use_package("cli") ## suggests ---- usethis::use_package("readr", type = "Suggests")