From 796f6fc4345619b22c26d2ea6e05749e50db92de Mon Sep 17 00:00:00 2001 From: Jason Everett Date: Tue, 23 Jun 2026 13:55:10 +1000 Subject: [PATCH 1/5] Fix errors --- .github/workflows/MacOS.yaml | 2 +- .github/workflows/Ubuntu.yaml | 2 +- .github/workflows/render-readme.yaml | 2 +- .github/workflows/test-coverage.yaml | 2 +- R/splnr_plotting_climate.R | 8 ++++---- 5 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/MacOS.yaml b/.github/workflows/MacOS.yaml index f44ef01d..f7870fbb 100644 --- a/.github/workflows/MacOS.yaml +++ b/.github/workflows/MacOS.yaml @@ -25,7 +25,7 @@ jobs: R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v7 - uses: r-lib/actions/setup-pandoc@v2 diff --git a/.github/workflows/Ubuntu.yaml b/.github/workflows/Ubuntu.yaml index 562a5052..832ca103 100644 --- a/.github/workflows/Ubuntu.yaml +++ b/.github/workflows/Ubuntu.yaml @@ -28,7 +28,7 @@ jobs: PKG_SYSREQS: false steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v7 - uses: r-lib/actions/setup-pandoc@v2 diff --git a/.github/workflows/render-readme.yaml b/.github/workflows/render-readme.yaml index a3970ee0..f1d0d7f5 100644 --- a/.github/workflows/render-readme.yaml +++ b/.github/workflows/render-readme.yaml @@ -18,7 +18,7 @@ jobs: contents: write steps: - name: Checkout repo - uses: actions/checkout@v4 + uses: actions/checkout@v7 with: fetch-depth: 0 diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index b8b6e9f8..379e0523 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -19,7 +19,7 @@ jobs: PKG_SYSREQS: false steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v7 - uses: r-lib/actions/setup-r@v2 with: diff --git a/R/splnr_plotting_climate.R b/R/splnr_plotting_climate.R index 9b92c66a..9b6789ef 100644 --- a/R/splnr_plotting_climate.R +++ b/R/splnr_plotting_climate.R @@ -313,8 +313,8 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, msg = "'colorMap' must be a character string for a 'viridis' palette option." ) assertthat::assert_that( - is.vector(legendTitle) || is.expression(legendTitle), - msg = "'legendTitle' must be a character string or an expression." + is.null(legendTitle) || is.vector(legendTitle) || is.expression(legendTitle), + msg = "'legendTitle' must be a character string, an expression, or NULL." ) assertthat::assert_that( is.vector(xAxisLab) || is.expression(xAxisLab), @@ -614,8 +614,8 @@ splnr_plot_climKernelDensity <- function(soln, msg = "'colorMap' must be a character string for a 'viridis' palette option." ) assertthat::assert_that( - is.vector(legendTitle) || is.expression(legendTitle), - msg = "'legendTitle' must be a character string or an expression." + is.null(legendTitle) || is.vector(legendTitle) || is.expression(legendTitle), + msg = "'legendTitle' must be a character string, an expression, or NULL." ) assertthat::assert_that( is.vector(xAxisLab) || is.expression(xAxisLab), From 8303458e4060db285e6eda259cce0006939ed2ac Mon Sep 17 00:00:00 2001 From: Jason Everett Date: Tue, 23 Jun 2026 14:25:20 +1000 Subject: [PATCH 2/5] Update theming --- R/splnr_featureRep.R | 21 +++++++----- R/splnr_gg_add.R | 9 ++--- R/splnr_plot.R | 7 +++- R/splnr_plotting.R | 67 ++++++++++++++++++++++++++++---------- R/splnr_plotting_climate.R | 43 ++++++++++++++---------- 5 files changed, 100 insertions(+), 47 deletions(-) diff --git a/R/splnr_featureRep.R b/R/splnr_featureRep.R index 311b70bb..b91297b6 100644 --- a/R/splnr_featureRep.R +++ b/R/splnr_featureRep.R @@ -438,6 +438,9 @@ splnr_get_featureRep <- function(soln, pDat, targets = NA, #' by which to sort the features on the x-axis. Accepted values include: #' `"category"`, `"feature"`, `"target"`, `"representation"` (`relative_held`), #' or `"difference"` (between representation and target). +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' @param ... Other arguments passed on to [ggplot2::theme()] to customize the plot's theme. #' #' @return A [ggplot2::ggplot] object representing the feature representation bar plot. @@ -500,6 +503,7 @@ splnr_plot_featureRep <- function(df, showTarget = NA, plotTitle = "", sort_by = "category", + base_size = 14, ...) { assertthat::assert_that( @@ -629,7 +633,7 @@ splnr_plot_featureRep <- function(df, fill = "NA", colour = "black" ) + ggplot2::labs(title = plotTitle, x = "Feature", y = "Representation of features \nin total selected area (%)") + - ggplot2::theme_bw() + + ggplot2::theme_bw(base_size = base_size) + # Ensure ymax is calculated correctly and handled for empty df ggplot2::scale_y_continuous( limits = c(0, max(df$relative_held, na.rm = TRUE, 0) + 10), # Ensure at least 0 if all NA @@ -642,16 +646,13 @@ splnr_plot_featureRep <- function(df, ) + ggplot2::guides(colour = "none") + ggplot2::theme( - axis.text.x = ggplot2::element_text(angle = 90, hjust = 1, vjust = 0.5, size = 16, colour = "black"), - axis.text.y = ggplot2::element_text(size = 16, colour = "black"), + axis.text.x = ggplot2::element_text(angle = 90, hjust = 1, vjust = 0.5, colour = "black"), + axis.text.y = ggplot2::element_text(colour = "black"), axis.title.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_text(size = 16), legend.title = ggplot2::element_blank(), - legend.text = ggplot2::element_text(size = 16), legend.position = "top", legend.direction = "horizontal", legend.background = ggplot2::element_rect(fill = "NA"), - title = ggplot2::element_text(size = 16), ... ) @@ -699,6 +700,9 @@ splnr_plot_featureRep <- function(df, #' percentage for 'representative' features. Required if `indicateTargets` is `TRUE`. #' @param colTarget A [character][base::character] string specifying the color #' for the target indicator lines. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_minimal()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A [ggplot2::ggplot] object of the circular bar plot. #' @export @@ -769,7 +773,8 @@ splnr_plot_featureRep <- function(df, #' } splnr_plot_circBplot <- function(df, legend_color, legend_list, indicateTargets = TRUE, impTarget = NA, - repTarget = NA, colTarget = "red") { + repTarget = NA, colTarget = "red", + base_size = 14) { # assertthat checks for initial inputs assertthat::assert_that( @@ -914,7 +919,7 @@ splnr_plot_circBplot <- function(df, legend_color, legend_list, # setting limitations of actual plot ggplot2::ylim(-130, 130) + # -140, 130 - ggplot2::theme_minimal() + + ggplot2::theme_minimal(base_size = base_size) + ggplot2::coord_polar() + ggplot2::geom_text( data = label_data, ggplot2::aes( diff --git a/R/splnr_gg_add.R b/R/splnr_gg_add.R index 6110320d..4ab2587f 100644 --- a/R/splnr_gg_add.R +++ b/R/splnr_gg_add.R @@ -92,6 +92,9 @@ #' labels (e.g. `c(Shipping_Lane = "Shipping Lane")`). #' When a single string is supplied it is used as the label for all areas. #' Defaults to `""`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()` when `ggtheme = "Default"`. All text elements scale +#' proportionally from this value. Defaults to `14`. #' @param ggtheme The `ggplot2` theme to apply. Can be: #' \itemize{ #' \item `NA` or `FALSE`: No theme is applied, using `ggplot2` defaults. @@ -186,6 +189,7 @@ splnr_gg_add <- function(PUs = NULL, colorPUs = "grey80", lockOut = NULL, typeLockOut = "Full", nameLockOut = NULL, alphaLockOut = 1, colorLockOut = "black", legendLockOut = "", labelLockOut = "", + base_size = 14, ggtheme = "Default") { # Assertions to validate input parameters are of the correct 'sf' class if not NULL. @@ -464,13 +468,10 @@ splnr_gg_add <- function(PUs = NULL, colorPUs = "grey80", ggList <- c( ggList, list( - ggplot2::theme_bw(), + ggplot2::theme_bw(base_size = base_size), ggplot2::theme( legend.position = "bottom", legend.direction = "horizontal", - text = ggplot2::element_text(size = 20, colour = "black"), - axis.text = ggplot2::element_text(size = 16, colour = "black"), - plot.title = ggplot2::element_text(size = 16), axis.title = ggplot2::element_blank() ) ) diff --git a/R/splnr_plot.R b/R/splnr_plot.R index 86a867f7..165dc975 100644 --- a/R/splnr_plot.R +++ b/R/splnr_plot.R @@ -41,6 +41,9 @@ #' @param legendLabels A character vector of strings to use for the legend labels, #' particularly useful for binary or logical data (e.g., `c("Absent", "Present")`). #' If `NULL`, default labels are used for binary/logical plots. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the spatial plot. #' @@ -112,7 +115,8 @@ splnr_plot <- function(df, colourVals = c("#c6dbef", "#3182bd"), plotTitle = "", legendTitle = NULL, - legendLabels = NULL) { + legendLabels = NULL, + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -194,6 +198,7 @@ splnr_plot <- function(df, # Initialize the base ggplot object with coordinate system and subtitle. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + ggplot2::coord_sf(xlim = sf::st_bbox(df)$xlim, ylim = sf::st_bbox(df)$ylim) + ggplot2::labs(subtitle = plotTitle) diff --git a/R/splnr_plotting.R b/R/splnr_plotting.R index a6d3441a..365d7988 100644 --- a/R/splnr_plotting.R +++ b/R/splnr_plotting.R @@ -41,6 +41,9 @@ #' @param legendLabels A character vector of strings to use for the legend labels, #' particularly useful for binary or logical data (e.g., `c("Absent", "Present")`). #' If `NULL`, default labels are used for binary/logical plots. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the spatial plot. #' @@ -112,7 +115,8 @@ splnr_plot <- function(df, colourVals = c("#c6dbef", "#3182bd"), plotTitle = "", legendTitle = NULL, - legendLabels = NULL) { + legendLabels = NULL, + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -194,6 +198,7 @@ splnr_plot <- function(df, # Initialize the base ggplot object with coordinate system and subtitle. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + ggplot2::coord_sf(xlim = sf::st_bbox(df)$xlim, ylim = sf::st_bbox(df)$ylim) + ggplot2::labs(subtitle = plotTitle) @@ -304,6 +309,9 @@ splnr_plot <- function(df, #' Defaults to `"Planning Units"`. #' @param zones A logical value. Set to `TRUE` if the `prioritizr` solution #' contains multiple zones (i.e., it's a multi-zone problem). Defaults to `FALSE`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the plot of the conservation solution. #' @export @@ -378,7 +386,7 @@ splnr_plot <- function(df, splnr_plot_solution <- function(soln, colorVals = c("#c6dbef", "#3182bd"), showLegend = TRUE, legendLabels = c("Not selected", "Selected"), plotTitle = "Solution", legendTitle = "Planning Units", - zones = FALSE) { + zones = FALSE, base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( inherits(soln, "sf"), # Ensure soln is an sf object. @@ -476,6 +484,7 @@ splnr_plot_solution <- function(soln, colorVals = c("#c6dbef", "#3182bd"), # Generate the ggplot object. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + # Add sf layer for the solution, filling by the 'solution' factor. ggplot2::geom_sf(data = soln, ggplot2::aes(fill = .data$solution), colour = NA, size = 0.1, show.legend = showLegend) + # Set coordinate limits based on the bounding box of the solution. @@ -531,6 +540,9 @@ splnr_plot_solution <- function(soln, colorVals = c("#c6dbef", "#3182bd"), #' Defaults to `"Cost"`. #' @param plotTitle A character string for the subtitle of the plot. #' Defaults to `"Solution overlaid with cost"`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the solution with cost overlay. #' @export @@ -582,7 +594,8 @@ splnr_plot_costOverlay <- function(soln, cost = NA, costName = "Cost", legendTitle = "Cost", - plotTitle = "Solution overlaid with cost") { + plotTitle = "Solution overlaid with cost", + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -631,6 +644,7 @@ splnr_plot_costOverlay <- function(soln, # Initialize the ggplot object. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + # Plot the selected solution units in black. ggplot2::geom_sf(data = soln, fill = "black", colour = "black", size = 0.0001) + # Overlay the cost data on top of the selected units with transparency. @@ -681,6 +695,9 @@ splnr_plot_costOverlay <- function(soln, #' with a `solution_1` column. This is the solution being compared against `soln1`. #' @param legendTitle A character string for the title of the legend. #' Defaults to `"Scenario 2 compared to Scenario 1:"`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the spatial comparison of the two solutions. #' @export @@ -728,7 +745,8 @@ splnr_plot_costOverlay <- function(soln, #' plot_comparison <- splnr_plot_comparison(dat_soln, dat_soln2) #' print(plot_comparison) #' } -splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compared to Scenario 1:") { +splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compared to Scenario 1:", + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -788,6 +806,7 @@ splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compar # Initialize the ggplot object. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + # Add sf layer for the comparison, filling by the 'Compare' factor. ggplot2::geom_sf(data = soln, ggplot2::aes(fill = .data$Compare), colour = NA, size = 0.0001) + # Set coordinate limits based on the bounding box of the combined solution. @@ -834,6 +853,9 @@ splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compar #' Defaults to `"Greens"`. #' @param legendTitle A character string for the title of the legend. #' Defaults to `"Selection \nFrequency"`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the plot of Planning Unit selection frequency. #' @export @@ -873,7 +895,8 @@ splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compar splnr_plot_selectionFreq <- function(selFreq, plotTitle = "", paletteName = "Greens", - legendTitle = "Selection \nFrequency") { + legendTitle = "Selection \nFrequency", + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -918,12 +941,11 @@ splnr_plot_selectionFreq <- function(selFreq, expand = TRUE ) + # Customize the plot theme. + ggplot2::theme_bw(base_size = base_size) + ggplot2::theme( - axis.text.y = ggplot2::element_text(size = 12, colour = "black"), - axis.text.x = ggplot2::element_text(size = 12, colour = "black"), + axis.text.y = ggplot2::element_text(colour = "black"), + axis.text.x = ggplot2::element_text(colour = "black"), axis.title.x = ggplot2::element_blank(), # Remove x-axis title. - legend.title = ggplot2::element_text(size = 12), - legend.text = ggplot2::element_text(size = 12), panel.grid = ggplot2::element_blank(), # Remove panel grid lines. panel.border = ggplot2::element_blank(), # Remove panel border. axis.ticks = ggplot2::element_blank(), # Remove axis ticks. @@ -978,6 +1000,9 @@ splnr_plot_selectionFreq <- function(selFreq, #' Defaults to `4`. #' @param legendTitle A character string for the title of the legend. #' Defaults to `"Importance Score"`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the plot of importance scores. #' @export @@ -1035,7 +1060,8 @@ splnr_plot_importanceScore <- function(soln, plotTitle = "", colorMap = "A", decimals = 4, - legendTitle = "Importance Score") { + legendTitle = "Importance Score", + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -1118,6 +1144,7 @@ splnr_plot_importanceScore <- function(soln, # Initialize the ggplot object. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + # Add sf layer, filling by the 'score' column. ggplot2::geom_sf(data = scored_soln, ggplot2::aes(fill = .data$score), colour = NA) + # Apply a viridis color scale for fill. @@ -1186,6 +1213,9 @@ splnr_plot_importanceScore <- function(soln, #' If `NULL` (default), the column names of `x` will be used. The length of #' this vector must match the number of rows/columns in `x`. #' @param plotTitle A character string for the title of the plot. Defaults to `""`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the correlation matrix plot. #' @export @@ -1239,7 +1269,8 @@ splnr_plot_importanceScore <- function(soln, #' } splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#4477AA"), legendTitle = "Correlation \ncoefficient", - AxisLabels = NULL, plotTitle = "") { + AxisLabels = NULL, plotTitle = "", + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -1279,9 +1310,12 @@ splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#447 } # Generate the correlation plot using ggcorrplot. + # Pass theme_bw(base_size) so that ggcorrplot's internal theme inherits the + # correct base font size rather than its own hardcoded default. gg <- ggcorrplot::ggcorrplot(x, outline.color = "black", # Set outline color for matrix cells. - lab = TRUE # Display correlation coefficients on the plot. + lab = TRUE, # Display correlation coefficients on the plot. + ggtheme = ggplot2::theme_bw(base_size = base_size) ) + # Apply a gradient fill for the correlation values. ggplot2::scale_fill_gradient2( @@ -1296,17 +1330,16 @@ splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#447 ) + # Rotate x-axis labels for better readability. ggplot2::scale_x_discrete(guide = ggplot2::guide_axis(angle = 45)) + - ggplot2::theme_bw() + # Apply a black and white theme. - # Customize the plot theme. + # Customize the plot theme — colour overrides only; sizes inherit from base_size. ggplot2::theme( legend.title = ggplot2::element_text(), # Keep default legend title text element. - legend.text = ggplot2::element_text(color = "black", size = 10), # Customize legend text. + legend.text = ggplot2::element_text(color = "black"), panel.grid = ggplot2::element_blank(), # Remove panel grid lines. panel.border = ggplot2::element_blank(), # Remove panel border. axis.ticks = ggplot2::element_blank(), # Remove axis ticks. - axis.text.y = ggplot2::element_text(color = "black", size = 12), # Customize y-axis text. + axis.text.y = ggplot2::element_text(color = "black"), axis.title = ggplot2::element_blank(), # Remove axis titles. - axis.text.x = ggplot2::element_text(color = "black", size = 12) # Customize x-axis text. + axis.text.x = ggplot2::element_text(color = "black") ) + ggplot2::labs(title = plotTitle) # Set plot title. diff --git a/R/splnr_plotting_climate.R b/R/splnr_plotting_climate.R index 9b6789ef..f9058a45 100644 --- a/R/splnr_plotting_climate.R +++ b/R/splnr_plotting_climate.R @@ -28,6 +28,9 @@ #' Defaults to `" "` (a single space, effectively no subtitle). #' @param legendTitle A character string for the title of the legend. #' Defaults to `"Climate metric"`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the spatial plot of the climate metric. #' @export @@ -65,7 +68,8 @@ splnr_plot_climData <- function(df, colInterest, colorMap = "C", plotTitle = " ", - legendTitle = "Climate metric") { + legendTitle = "Climate metric", + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -95,6 +99,7 @@ splnr_plot_climData <- function(df, # Initialize the ggplot object. gg <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = base_size) + # Add sf layer, filling by the specified climate metric column. ggplot2::geom_sf(data = df %>% sf::st_as_sf(), ggplot2::aes(fill = !!rlang::sym(colInterest)), colour = NA) + # Apply a viridis continuous color scale for fill. @@ -142,7 +147,7 @@ splnr_plot_climData <- function(df, #' @importFrom ggplot2 aes element_blank element_line element_text ggplot labs scale_fill_manual scale_x_continuous scale_y_discrete theme theme_bw guide_legend #' @importFrom rlang .data := #' -splnr_plot_climKernelDensity_Basic <- function(soln) { +splnr_plot_climKernelDensity_Basic <- function(soln, base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -204,18 +209,16 @@ splnr_plot_climKernelDensity_Basic <- function(soln) { x = "Climate resilience metric", y = "Proportion of planning units" ) + - ggplot2::theme_bw() + # Apply black and white theme. - # Customize theme elements. + ggplot2::theme_bw(base_size = base_size) + # Apply black and white theme. + # Customize theme elements — colour/layout overrides only; sizes inherit from base_size. ggplot2::theme( axis.ticks = ggplot2::element_line(color = "black", linewidth = 1), - text = ggplot2::element_text(size = 20), axis.line = ggplot2::element_line(colour = "black", linewidth = 1), axis.text.y = ggplot2::element_blank(), # Hide y-axis text. - axis.text.x = ggplot2::element_text(size = 20), - axis.title = ggplot2::element_text(size = 20), + axis.text.x = ggplot2::element_text(colour = "black"), legend.title = ggplot2::element_text(color = "black", angle = 90, hjust = 0.5), # Rotate legend title. legend.position = "bottom", - legend.text = ggplot2::element_text(size = 20) + legend.text = ggplot2::element_text(colour = "black") ) + # Manually set fill colors for "Not Selected" and "Selected" in the legend. ggplot2::scale_fill_manual( @@ -276,7 +279,8 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, climate_name = "metric", colorMap = "C", legendTitle = expression(" \u00B0C y"^"-1" * ""), - xAxisLab = expression("Climate warming ( \u00B0C y"^"-1" * ")")) { + xAxisLab = expression("Climate warming ( \u00B0C y"^"-1" * ")"), + base_size = 14) { # --- Input validation ------------------------------------------------------- @@ -433,16 +437,16 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, ggplot2::scale_x_continuous(expand = c(0, 0)) + ggplot2::scale_y_discrete(expand = ggplot2::expansion(mult = c(0.01, 0))) + ggplot2::labs(x = xAxisLab) + - ggplot2::theme_bw() + + ggplot2::theme_bw(base_size = base_size) + + # Colour/layout overrides only; sizes inherit from base_size. ggplot2::theme( axis.ticks = ggplot2::element_line(color = "black", linewidth = 1), axis.line = ggplot2::element_line(colour = "black", linewidth = 1), - axis.text = ggplot2::element_text(color = "black", size = 14), - axis.title.x = ggplot2::element_text(size = 14), + axis.text = ggplot2::element_text(color = "black"), axis.title.y = ggplot2::element_blank(), axis.text.y = ggplot2::element_blank(), - legend.text = ggplot2::element_text(size = 15, color = "black"), - legend.title = ggplot2::element_text(size = 15, color = "black"), + legend.text = ggplot2::element_text(color = "black"), + legend.title = ggplot2::element_text(color = "black"), legend.title.position = "right" ) @@ -494,6 +498,9 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, #' `expression(" \u00B0C y"^"-1" * "")`, representing "°C year⁻¹". #' @param xAxisLab A character string or `expression` for the x-axis label. #' Defaults to `expression("Climate warming ( \u00B0C y"^"-1" * ")")`. +#' @param base_size A numeric value for the base font size (in points) passed to +#' `ggplot2::theme_bw()`. All text elements scale proportionally from this value. +#' Defaults to `14`. #' #' @return A `ggplot` object representing the kernel density plot. #' @export @@ -590,7 +597,8 @@ splnr_plot_climKernelDensity <- function(soln, type = "Normal", colorMap = "C", legendTitle = expression(" \u00B0C y"^"-1" * ""), - xAxisLab = expression("Climate warming ( \u00B0C y"^"-1" * ")")) { + xAxisLab = expression("Climate warming ( \u00B0C y"^"-1" * ")"), + base_size = 14) { # Assertions to validate input parameters. assertthat::assert_that( @@ -636,14 +644,15 @@ splnr_plot_climKernelDensity <- function(soln, climate_name = climate_name, colorMap = colorMap, legendTitle = legendTitle, - xAxisLab = xAxisLab + xAxisLab = xAxisLab, + base_size = base_size ) } else if (type == "Basic") { # If type is "Basic", expect a single sf object. if (!inherits(soln, "sf")) { stop("For 'type = \"Basic\"', 'soln' must be a single sf object.") } - ggclimDens <- splnr_plot_climKernelDensity_Basic(soln = soln) + ggclimDens <- splnr_plot_climKernelDensity_Basic(soln = soln, base_size = base_size) } else { # This case should ideally be caught by initial assertthat, but kept as a fallback. stop("Invalid 'type' specified. Must be 'Normal' or 'Basic'.") From 22412f3ed72292f1bb15b0da66add0af78878d83 Mon Sep 17 00:00:00 2001 From: Jason Everett Date: Tue, 23 Jun 2026 14:34:46 +1000 Subject: [PATCH 3/5] Fix cost bar width --- R/splnr_plotting.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/splnr_plotting.R b/R/splnr_plotting.R index 365d7988..820630fd 100644 --- a/R/splnr_plotting.R +++ b/R/splnr_plotting.R @@ -659,7 +659,11 @@ splnr_plot_costOverlay <- function(soln, 0, as.numeric(stats::quantile(dplyr::pull(Cost, costName), 0.99, na.rm = TRUE)) ), - oob = scales::squish # Squish values outside the limits. + oob = scales::squish, # Squish values outside the limits. + guide = ggplot2::guide_colourbar( + barwidth = ggplot2::unit(20, "lines"), # Twice the width of the climate colourbar (10 lines). + barheight = ggplot2::unit(6, "lines") # Twice the height of the climate colourbar (3 lines). + ) ) + # Set coordinate limits based on the bounding box of the cost data. ggplot2::coord_sf(xlim = sf::st_bbox(Cost)$xlim, ylim = sf::st_bbox(Cost)$ylim) + From f9d0d334a51f15ce2b057f0f72c5a4d191130121 Mon Sep 17 00:00:00 2001 From: Jason Everett Date: Tue, 23 Jun 2026 15:07:59 +1000 Subject: [PATCH 4/5] Update tests and dead code --- R/splnr_featureRep.R | 4 +- R/splnr_plotting.R | 34 ++--- R/utils.R | 9 -- tests/testthat/test-splnr_apply_cutoffs.R | 26 ++++ tests/testthat/test-splnr_featureRep.R | 175 ++++++++++++++++++++++ tests/testthat/test-splnr_plot.R | 135 +++++++++++++++++ tests/testthat/test-splnr_plotting.R | 35 +++++ tests/testthat/test-utils-climate.R | 49 ++++++ tests/testthat/test-utils.R | 27 ++++ 9 files changed, 460 insertions(+), 34 deletions(-) diff --git a/R/splnr_featureRep.R b/R/splnr_featureRep.R index b91297b6..5576f314 100644 --- a/R/splnr_featureRep.R +++ b/R/splnr_featureRep.R @@ -293,7 +293,7 @@ splnr_get_featureRep <- function(soln, pDat, targets = NA, # Climate Priority Area (CPA) approach: features were split into _CS and _NCS # components. Aggregate them back to the original feature name. s1 <- s1 %>% - dplyr::select(-.data$relative_held) %>% + dplyr::select(-"relative_held") %>% dplyr::mutate( feature = stringr::str_remove_all(.data$feature, "_CS"), feature = stringr::str_remove_all(.data$feature, "_NCS") @@ -542,7 +542,7 @@ splnr_plot_featureRep <- function(df, ) ) category <- category %>% - dplyr::rename(feature = categoryFeatureCol) + dplyr::rename(feature = !!rlang::sym(categoryFeatureCol)) } diff --git a/R/splnr_plotting.R b/R/splnr_plotting.R index 820630fd..e87131eb 100644 --- a/R/splnr_plotting.R +++ b/R/splnr_plotting.R @@ -404,10 +404,6 @@ splnr_plot_solution <- function(soln, colorVals = c("#c6dbef", "#3182bd"), is.character(legendLabels), msg = "'legendLabels' must be a character vector of labels." ) - assertthat::assert_that( - length(colorVals) == length(legendLabels), - msg = "The number of 'colorVals' must match the number of 'legendLabels'." - ) assertthat::assert_that( is.character(plotTitle), # plotTitle should be character. msg = "'plotTitle' must be a character string." @@ -463,10 +459,6 @@ splnr_plot_solution <- function(soln, colorVals = c("#c6dbef", "#3182bd"), solution = sum(dplyr::c_across(cols = tidyselect::starts_with("solution_"))), # Sum across solution columns. solution = factor(.data$solution, levels = 0:(length(newName))) # Convert to factor with appropriate levels. ) - } else { - # If 'zones' parameter is not a logical value, print an error. - cat("The 'zones' attribute requires a logical input. Please set to TRUE or FALSE.") - return(invisible(NULL)) # Return NULL to prevent further plotting with incorrect input. } # Quick checks to ensure color and label lengths match solution levels. @@ -619,22 +611,24 @@ splnr_plot_costOverlay <- function(soln, msg = "'plotTitle' must be a character string." ) - # Check if Cost is provided as NA and if costName exists in soln. - if (is.na(cost)) { + # Check if cost is provided as NA and if costName exists in soln. + if (length(cost) == 1 && is.na(cost)) { if (!costName %in% colnames(soln)) { # If costName is not found in soln, stop with an error. - stop(paste0("Cost column '", costName, "' not found in the solution data frame. Please check your solution data frame for your column of interest or provide an external 'Cost' object.")) + stop(paste0("Cost column '", costName, "' not found in the solution data frame. Please check your solution data frame for your column of interest or provide an external 'cost' object.")) } else { # If costName is in soln, select it. Cost <- soln %>% dplyr::select(!!rlang::sym(costName)) } - } else if (!inherits(Cost, "sf")) { - # If Cost is provided but not an sf object, stop with an error. - stop("'Cost' must be an 'sf' object if provided, not a data.frame or other type.") - } else if (!(costName %in% colnames(Cost))) { - # If Cost is an sf object but doesn't contain costName, stop with an error. - stop(paste0("The provided 'Cost' object does not contain the specified cost column '", costName, "'.")) + } else if (!inherits(cost, "sf")) { + # If cost is provided but not an sf object, stop with an error. + stop("'cost' must be an 'sf' object if provided, not a data.frame or other type.") + } else if (!(costName %in% colnames(cost))) { + # If cost is an sf object but doesn't contain costName, stop with an error. + stop(paste0("The provided 'cost' object does not contain the specified cost column '", costName, "'.")) + } else { + Cost <- cost } # Filter the solution to only include selected Planning Units. @@ -1302,12 +1296,6 @@ splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#447 msg = "'plotTitle' must be a character string." ) - # Check if AxisLabels length matches matrix dimensions if provided. - if (!is.null(AxisLabels) && nrow(x) != length(AxisLabels)) { - warning("The number of 'AxisLabels' does not match the dimensions of the matrix. Using default labels.") - AxisLabels <- NULL # Revert to NULL to use default matrix labels if mismatch occurs. - } - # Check if ggcorrplot package is installed, if not, stop with an error. if (requireNamespace("ggcorrplot", quietly = TRUE) == FALSE){ stop("To run splnr_plot_corrMat you will need to install the package ggcorrplot.") diff --git a/R/utils.R b/R/utils.R index 0cc1fd77..a0ff53db 100644 --- a/R/utils.R +++ b/R/utils.R @@ -634,11 +634,6 @@ splnr_get_kappaCorrData <- function(sol, name_sol) { ) } - # Check if 'irr' package is installed. If not, stop with an informative error. - if (requireNamespace("irr", quietly = TRUE) == FALSE){ - stop("To run splnr_get_kappaCorrData you will need to install the 'irr' package: install.packages('irr').") - } - # Prepare a list of solutions, selecting only the 'solution_1' column and renaming it # with the provided 'name_sol'. Each element will be a tibble with one column. s_list <- lapply(seq_along(sol), function(x) { @@ -869,9 +864,5 @@ splnr_get_selFreq <- function(solnMany, type = "portfolio") { sf::st_as_sf(geometry = sf::st_geometry(solnMany[[1]])) %>% # Convert back to sf dplyr::select("selFreq") # Select only the calculated selection frequency column. return(selFreq) - - } else { - # This block should technically not be reached due to initial assertthat. - stop("This function requires either a prioritizr portfolio or a list of solutions. Please check your input.") } } diff --git a/tests/testthat/test-splnr_apply_cutoffs.R b/tests/testthat/test-splnr_apply_cutoffs.R index 5f8d658b..0d90ecc2 100644 --- a/tests/testthat/test-splnr_apply_cutoffs.R +++ b/tests/testthat/test-splnr_apply_cutoffs.R @@ -202,3 +202,29 @@ testthat::test_that("non-logical inverse raises an error", { "must be a single logical value" ) }) + +# --- resolve_cutoff() internal error branches --- + +testthat::test_that("function-based cutoff that throws an error is re-raised with context", { + # The tryCatch inside resolve_cutoff() catches errors from the user's function + # and re-throws them with a more informative message. + expect_error( + splnr_apply_cutoffs( + dat_species_prob, + Cutoffs = \(x) stop("deliberate error in cutoff function") + ), + "raised an error" + ) +}) + +testthat::test_that("named list entry that is neither numeric nor function raises an error", { + # The else branch in resolve_cutoff() handles entries that are not numeric + # scalars or functions (e.g. a character string). + expect_error( + splnr_apply_cutoffs( + dat_species_prob, + Cutoffs = list("Spp1" = "not_a_number_or_function") + ), + "must be a numeric scalar or a function" + ) +}) diff --git a/tests/testthat/test-splnr_featureRep.R b/tests/testthat/test-splnr_featureRep.R index a179b0c8..98a74361 100644 --- a/tests/testthat/test-splnr_featureRep.R +++ b/tests/testthat/test-splnr_featureRep.R @@ -138,3 +138,178 @@ testthat::test_that("Correct function output", { ) }) + +# --- targets validation (lines 234-241) --- + +testthat::test_that("splnr_get_featureRep() errors when targets is not a data.frame", { + expect_error( + splnr_get_featureRep( + soln = soln, + pDat = pDat, + targets = "not_a_dataframe", + climsmart = TRUE, + climsmartApproach = 3 + ), + "must be a data.frame" + ) +}) + +testthat::test_that("splnr_get_featureRep() errors when targets data.frame is missing required columns", { + bad_targets <- data.frame(feature = c("Spp1", "Spp2", "Spp3")) + expect_error( + splnr_get_featureRep( + soln = soln, + pDat = pDat, + targets = bad_targets, + climsmart = TRUE, + climsmartApproach = 3 + ), + "must contain 'feature' and 'target' columns" + ) +}) + + +# --- climsmart approaches (lines 295-317) --- + +testthat::test_that("splnr_get_featureRep() works with climsmart=TRUE, climsmartApproach=1 (CPA)", { + # Build a CPA problem: features are split into _CS and _NCS columns. + targets_df <- dat_species_bin %>% + sf::st_drop_geometry() %>% + colnames() %>% + data.frame() %>% + setNames(c("feature")) %>% + dplyr::mutate(target = 0.3) + + cpa <- splnr_climate_priorityAreaApproach( + features = dat_species_bin, + metric = dat_clim, + targets = targets_df, + direction = -1, + percentile = 5, + refugiaTarget = 1 + ) + + cpa_sf <- cpa$Features %>% + dplyr::mutate(Cost = 1) + + cpa_features <- cpa_sf %>% + sf::st_drop_geometry() %>% + dplyr::select(-"Cost") %>% + names() + + pDat_cpa <- prioritizr::problem(cpa_sf, cpa_features, "Cost") %>% + prioritizr::add_min_set_objective() %>% + prioritizr::add_relative_targets(cpa$Targets$target) %>% + prioritizr::add_binary_decisions() %>% + prioritizr::add_default_solver(verbose = FALSE) + + soln_cpa <- prioritizr::solve.ConservationProblem(pDat_cpa) + + df <- splnr_get_featureRep( + soln = soln_cpa, + pDat = pDat_cpa, + targets = targets_df, + climsmart = TRUE, + climsmartApproach = 1 + ) + + # Should return one row per original feature (not per CS/NCS split) + expect_s3_class(df, "tbl_df") + expect_equal(nrow(df), nrow(targets_df)) + expect_true(all(c("feature", "total_amount", "absolute_held", + "relative_held", "target") %in% names(df))) +}) + + +testthat::test_that("splnr_get_featureRep() works with climsmart=TRUE, climsmartApproach=3 (percentile)", { + targets_df <- dat_species_bin %>% + sf::st_drop_geometry() %>% + colnames() %>% + data.frame() %>% + setNames(c("feature")) %>% + dplyr::mutate(target = 0.3) + + pct <- splnr_climate_percentileApproach( + features = dat_species_bin, + metric = dat_clim, + targets = targets_df, + direction = 1, + percentile = 50 + ) + + pct_sf <- pct$Features %>% + dplyr::mutate(Cost = 1) + + pct_features <- pct_sf %>% + sf::st_drop_geometry() %>% + dplyr::select(-"Cost") %>% + names() + + pDat_pct <- prioritizr::problem(pct_sf, pct_features, "Cost") %>% + prioritizr::add_min_set_objective() %>% + prioritizr::add_relative_targets(pct$Targets$target) %>% + prioritizr::add_binary_decisions() %>% + prioritizr::add_default_solver(verbose = FALSE) + + soln_pct <- prioritizr::solve.ConservationProblem(pDat_pct) + + df <- splnr_get_featureRep( + soln = soln_pct, + pDat = pDat_pct, + targets = pct$Targets, + climsmart = TRUE, + climsmartApproach = 3 + ) + + expect_s3_class(df, "tbl_df") + expect_equal(nrow(df), nrow(targets_df)) + expect_true(all(c("feature", "total_amount", "absolute_held", + "relative_held", "target") %in% names(df))) +}) + + +# --- splnr_plot_featureRep() renameFeatures and categoryFeatureCol paths --- + +testthat::test_that("splnr_plot_featureRep() works with renameFeatures=TRUE", { + df <- splnr_get_featureRep(soln = soln, pDat = pDat) + + names_to_replace <- tibble::tibble( + nameVariable = c("Spp1", "Spp2", "Spp3"), + nameCommon = c("Species One", "Species Two", "Species Three") + ) + + expect_s3_class( + splnr_plot_featureRep( + df, + category = dat_category, + renameFeatures = TRUE, + namesToReplace = names_to_replace, + showTarget = TRUE + ), + "gg" + ) +}) + + +testthat::test_that("splnr_plot_featureRep() works with categoryFeatureCol when category lacks 'feature' column", { + df <- splnr_get_featureRep(soln = soln, pDat = pDat) + + # Build a category tibble that uses "Species" instead of "feature" as the + # identifier column — this triggers the categoryFeatureCol rename path + # (lines 534-546 of splnr_featureRep.R). + cat_no_feature_col <- tibble::tibble( + Species = c("Spp1", "Spp2", "Spp3"), + category = c("Group1", "Group1", "Group2") + ) + + expect_s3_class( + splnr_plot_featureRep( + df, + category = cat_no_feature_col, + categoryFeatureCol = "Species", + showTarget = TRUE + ), + "gg" + ) +}) + diff --git a/tests/testthat/test-splnr_plot.R b/tests/testthat/test-splnr_plot.R index 01b1008f..41433cac 100644 --- a/tests/testthat/test-splnr_plot.R +++ b/tests/testthat/test-splnr_plot.R @@ -231,3 +231,138 @@ testthat::test_that("splnr_gg_add() Full lock-out uses named labelLockOut vector }) +# --------------------------------------------------------------------------- +# Local solution object for costOverlay and contours tests +# (soln1 lives in test-splnr_plotting.R; each test file is independent) +# --------------------------------------------------------------------------- +dat_soln_with_cost <- dat_species_bin %>% + dplyr::mutate(Cost = runif(n = dplyr::n())) + +pDat_local <- prioritizr::problem( + dat_soln_with_cost, + features = c("Spp1", "Spp2", "Spp3"), + cost_column = "Cost" +) %>% + prioritizr::add_min_set_objective() %>% + prioritizr::add_relative_targets(0.3) %>% + prioritizr::add_binary_decisions() %>% + prioritizr::add_default_solver(verbose = FALSE) + +soln_local <- prioritizr::solve.ConservationProblem(pDat_local) + + +# --------------------------------------------------------------------------- +# splnr_gg_add() contours path (lines 294-325 of splnr_gg_add.R) +# --------------------------------------------------------------------------- +# The contours branch is entered when an sf object with a "Category" column +# is passed. It adds a geom_sf with a linetype aesthetic and a +# scale_linetype_manual layer. We verify the plot builds without error. + +testthat::test_that("splnr_gg_add() contours path produces a gg object", { + # Build a minimal contours sf: two categories so we exercise the + # seq_along(nameConts) path with length > 1. + contours_sf <- dat_mpas %>% + dplyr::mutate(Category = dplyr::if_else(.data$wdpa == 1L, "MPA", "Other")) + + gg <- splnr_plot(dat_species_bin, colNames = "Spp1", + legendTitle = "Spp1", legendLabels = c("Absent", "Present")) + + splnr_gg_add( + contours = contours_sf, + ggtheme = FALSE + ) + + expect_s3_class(gg, "gg") + + # Confirm a geom_sf layer whose data has a "Category" column was added + has_category_layer <- any(vapply( + gg$layers, + function(l) "Category" %in% names(l$data), + logical(1) + )) + expect_true(has_category_layer) +}) + + +# --------------------------------------------------------------------------- +# splnr_gg_add() list ggtheme path (line 481-482 of splnr_gg_add.R) +# --------------------------------------------------------------------------- +# When ggtheme is a list of ggplot2 theme elements, the list branch is taken +# and each element is appended to ggList individually (not wrapped in list()). + +testthat::test_that("splnr_gg_add() list ggtheme path appends theme elements", { + list_theme <- list( + ggplot2::theme_bw(), + ggplot2::theme(legend.position = "right") + ) + + gg <- splnr_plot(dat_species_bin, colNames = "Spp1", + legendTitle = "Spp1", legendLabels = c("Absent", "Present")) + + splnr_gg_add(ggtheme = list_theme) + + expect_s3_class(gg, "gg") +}) + + +# --------------------------------------------------------------------------- +# splnr_plot_costOverlay() missing costName error (line 622 of splnr_plotting.R) +# --------------------------------------------------------------------------- +# When cost=NA (default) and costName is not a column in soln, the function +# should stop with an informative error message. + +testthat::test_that("splnr_plot_costOverlay() errors when costName is absent from soln", { + expect_error( + splnr_plot_costOverlay( + soln = soln_local, + costName = "NonExistentCostColumn" + ), + "not found in the solution data frame" + ) +}) + + +# --------------------------------------------------------------------------- +# splnr_plot_costOverlay() external cost branches (fixed bug: cost vs Cost) +# --------------------------------------------------------------------------- +# Branch 2: cost is provided but is not an sf object → stop() +# Branch 3: cost is an sf object but does not contain costName → stop() +# Branch 4 (happy path): cost is a valid sf with the costName column → gg + +testthat::test_that("splnr_plot_costOverlay() errors when cost is not an sf object", { + # Pass a plain data.frame (not sf) as cost — triggers the !inherits(cost, "sf") branch. + plain_df <- sf::st_drop_geometry(soln_local) + expect_error( + splnr_plot_costOverlay( + soln = soln_local, + cost = plain_df, + costName = "Cost" + ), + "'cost' must be an 'sf' object" + ) +}) + +testthat::test_that("splnr_plot_costOverlay() errors when cost sf lacks the costName column", { + # Pass a valid sf object that does NOT contain the requested costName column. + cost_sf_no_col <- soln_local %>% dplyr::select("solution_1") # no "MyCost" column + expect_error( + splnr_plot_costOverlay( + soln = soln_local, + cost = cost_sf_no_col, + costName = "MyCost" + ), + "does not contain the specified cost column" + ) +}) + +testthat::test_that("splnr_plot_costOverlay() works when a valid external cost sf is supplied", { + # Pass soln_local itself as the external cost object (it contains "Cost"). + expect_s3_class( + splnr_plot_costOverlay( + soln = soln_local, + cost = soln_local, + costName = "Cost" + ), + "gg" + ) +}) + + diff --git a/tests/testthat/test-splnr_plotting.R b/tests/testthat/test-splnr_plotting.R index bb1e6ffe..1afc0082 100644 --- a/tests/testthat/test-splnr_plotting.R +++ b/tests/testthat/test-splnr_plotting.R @@ -147,3 +147,38 @@ testthat::test_that("Correct function output", { }) +# --------------------------------------------------------------------------- +# splnr_plot_solution() zones colorVals / legendLabels mismatch warnings +# (lines 473-483 of splnr_plotting.R) +# --------------------------------------------------------------------------- +# When the number of colorVals or legendLabels does not match the number of +# factor levels in the solution column, a warning is issued. The zones=TRUE +# path creates levels 0, 1, 2 (3 levels) for a two-zone problem. + +testthat::test_that("splnr_plot_solution() warns when colorVals length mismatches solution levels", { + expect_warning( + splnr_plot_solution( + soln_zone, + zones = TRUE, + # Only 2 colours for 3 levels (0 = not selected, 1 = zone 1, 2 = zone 2) + colorVals = c("#c6dbef", "#3182bd"), + legendLabels = c("Not selected", "Zone 1", "Zone 2") + ), + "colorVals" + ) +}) + +testthat::test_that("splnr_plot_solution() warns when legendLabels length mismatches solution levels", { + expect_warning( + splnr_plot_solution( + soln_zone, + zones = TRUE, + colorVals = c("#c6dbef", "#3182bd", "black"), + # Only 2 labels for 3 levels + legendLabels = c("Not selected", "Zone 1") + ), + "legendLabels" + ) +}) + + diff --git a/tests/testthat/test-utils-climate.R b/tests/testthat/test-utils-climate.R index 96ab9308..8465505a 100644 --- a/tests/testthat/test-utils-climate.R +++ b/tests/testthat/test-utils-climate.R @@ -135,3 +135,52 @@ testthat::test_that("splnr_climate_percentileApproach() returns correct structur # Targets has one row per input feature expect_equal(nrow(result$Targets), length(feat_names)) }) + + +# --------------------------------------------------------------------------- +# splnr_climate_percentile_preprocess() NA metric warning (line 1004-1009) +# --------------------------------------------------------------------------- +# When the metric column contains NAs, a warning is issued before the +# per-feature percentile loop. We inject NAs into a copy of dat_clim. + +testthat::test_that("splnr_climate_percentileApproach() warns when metric contains NAs", { + # Introduce NAs into the metric column for a handful of planning units. + dat_clim_na <- dat_clim %>% + dplyr::mutate(metric = dplyr::if_else(dplyr::row_number() <= 10L, NA_real_, .data$metric)) + + expect_warning( + splnr_climate_percentileApproach( + features = dat_species_bin, + metric = dat_clim_na, + targets = targets, + direction = 1 + ), + "NAs present in the metric data" + ) +}) + + +# --------------------------------------------------------------------------- +# splnr_climate_percentile_preprocess() direction = -1 branch (lines 1047-1048) +# --------------------------------------------------------------------------- +# When direction = -1, the climate-smart filter keeps planning units whose +# metric value is <= the percentile threshold (cold/low-stress refugia). +# The existing test only uses direction = 1; this test exercises direction = -1. + +testthat::test_that("splnr_climate_percentileApproach() works with direction = -1", { + result <- splnr_climate_percentileApproach( + features = dat_species_bin, + metric = dat_clim, + targets = targets, + direction = -1, + percentile = 35 + ) + + # Basic structure checks + expect_true(rlang::is_list(result)) + expect_named(result, c("Features", "Targets")) + expect_s3_class(result$Features, "sf") + expect_equal(nrow(result$Features), nrow(dat_species_bin)) + expect_true(all(feat_names %in% names(result$Features))) + expect_equal(nrow(result$Targets), length(feat_names)) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 12e21071..86aee2ad 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -116,3 +116,30 @@ testthat::test_that("Correct function output", { splnr_get_selFreq(solnMany = list(soln1, soln2), type = "list"), "sf" ) }) + + +# --------------------------------------------------------------------------- +# splnr_featureNames() with custom exclude argument (line 433 of utils.R) +# --------------------------------------------------------------------------- +# The default exclude = NA only strips columns starting with "Cost_". +# When a non-NA character vector is supplied, those prefixes are also excluded. +# This test exercises the else branch at line 430-434. + +testthat::test_that("splnr_featureNames() with custom exclude drops matching columns", { + # Add a column starting with "Spp1" and one starting with "Extra_" so we can + # verify that passing exclude = "Spp1" removes it while keeping the others. + dat_extra <- dat_species_prob %>% + dplyr::mutate(Extra_col = 1.0) + + # Default: all species columns + Extra_col are returned (Cost_ prefix absent) + all_names <- splnr_featureNames(dat_extra) + expect_true("Extra_col" %in% all_names) + + # With custom exclude: "Extra_" prefix columns should be dropped + filtered_names <- splnr_featureNames(dat_extra, exclude = "Extra_") + expect_false("Extra_col" %in% filtered_names) + + # The remaining species columns should still be present + spp_cols <- grep("^Spp", all_names, value = TRUE) + expect_true(all(spp_cols %in% filtered_names)) +}) From 83cfa1aed95bab75f4309a128ba590b43d71fa8e Mon Sep 17 00:00:00 2001 From: Jason Everett Date: Tue, 23 Jun 2026 15:09:27 +1000 Subject: [PATCH 5/5] Style package --- R/splnr_apply_cutoffs.R | 12 +- R/splnr_deprecated.R | 18 -- R/splnr_featureRep.R | 26 +- R/splnr_get_IUCNRedList.R | 11 +- R/splnr_get_MPAs.R | 32 +-- R/splnr_get_distCoast.R | 2 +- R/splnr_get_gfw.R | 61 ++--- R/splnr_gg_add.R | 61 +++-- R/splnr_plot.R | 54 ++-- R/splnr_plotting.R | 81 +++--- R/splnr_plotting_climate.R | 59 ++--- R/splnr_targets.R | 20 +- R/utils-climate.R | 75 +++--- R/utils.R | 21 +- data-raw/CreateHex.R | 60 ++--- data-raw/DATASET.R | 11 +- data-raw/splnr_Create_SinglePolygon.R | 2 - data-raw/splnr_convert_toPacific.R | 2 - data-raw/testOptimalityGap.R | 165 ++++++------ tests/testthat/test-splnr_apply_cutoffs.R | 35 ++- tests/testthat/test-splnr_featureRep.R | 45 ++-- tests/testthat/test-splnr_get_MPAs.R | 1 - tests/testthat/test-splnr_get_boundary.R | 12 +- tests/testthat/test-splnr_get_distCoast.R | 2 - tests/testthat/test-splnr_plot.R | 119 +++++---- tests/testthat/test-splnr_plotting.R | 69 +++-- tests/testthat/test-splnr_plotting_climate.R | 21 +- tests/testthat/test-splnr_targets.R | 1 - tests/testthat/test-utils-climate.R | 9 +- tests/testthat/test-utils.R | 35 ++- vignettes/ClimateSmart.Rmd | 122 ++++----- vignettes/GlobalFishingWatch.Rmd | 80 +++--- vignettes/MultipleUse.Rmd | 104 ++++---- vignettes/spatialplanr.Rmd | 252 ++++++++++--------- 34 files changed, 850 insertions(+), 830 deletions(-) diff --git a/R/splnr_apply_cutoffs.R b/R/splnr_apply_cutoffs.R index 523b267c..8f1c2b45 100644 --- a/R/splnr_apply_cutoffs.R +++ b/R/splnr_apply_cutoffs.R @@ -118,7 +118,6 @@ #' df_inverse_cutoff <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0.5, inverse = TRUE) #' print(df_inverse_cutoff) splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { - # --- Input Assertions --- assertthat::assert_that( @@ -186,9 +185,7 @@ splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { # col_name: used only for error messages. resolve_cutoff <- function(entry, col_values, col_name) { - if (is.numeric(entry)) { - assertthat::assert_that( length(entry) == 1, msg = paste0( @@ -197,9 +194,7 @@ splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { ) ) threshold <- entry - } else if (is.function(entry)) { - # Strip NAs before passing to the user's function so that common # aggregation functions (quantile, mean, etc.) work without the user # needing to remember na.rm = TRUE. @@ -224,7 +219,6 @@ splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { "Got: ", deparse(threshold) ) ) - } else { stop( "Each entry in 'Cutoffs' must be a numeric scalar or a function. ", @@ -266,7 +260,6 @@ splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { thresh } ) - } else if (is.numeric(Cutoffs) && is.null(names(Cutoffs)) && length(Cutoffs) == 1) { # Single numeric scalar: same threshold for every numeric column. # Validate once against the first column (value check only; column data @@ -274,7 +267,6 @@ splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { message("Applying single cutoff of ", Cutoffs, " to all numeric feature columns.") resolve_cutoff(Cutoffs, features_plain[[numeric_cols[1]]], numeric_cols[1]) thresholds <- stats::setNames(rep(Cutoffs, length(numeric_cols)), numeric_cols) - } else { # Named numeric vector or named list: per-column thresholds. # Convert a named numeric vector to a list so resolve_cutoff handles both @@ -308,9 +300,9 @@ splnr_apply_cutoffs <- function(features, Cutoffs, inverse = FALSE) { features_tbl <- features_tbl %>% dplyr::mutate( !!rlang::sym(col) := dplyr::case_when( - is.na(!!rlang::sym(col)) ~ 0, + is.na(!!rlang::sym(col)) ~ 0, !!rlang::sym(col) >= thresh ~ 1, - TRUE ~ 0 + TRUE ~ 0 ) ) } diff --git a/R/splnr_deprecated.R b/R/splnr_deprecated.R index 4df12846..a3eec5c8 100644 --- a/R/splnr_deprecated.R +++ b/R/splnr_deprecated.R @@ -21,9 +21,7 @@ #' df <- splnr_convert_regionalisation(dat, PUs) #' } splnr_convert_regionalisation <- function(dat, PUs, cat_name = NA, col_name = NA) { - lifecycle::deprecate_stop("0.6.2", "splnr_convert_regionalisation()", "spatialgridr::get_data_in_grid()") - } @@ -49,14 +47,10 @@ splnr_convert_regionalisation <- function(dat, PUs, cat_name = NA, col_name = NA #' df <- splnr_convert_toPUs(dat, PlanUnits) #' } splnr_convert_toPUs <- function(dat, PlanUnits) { - lifecycle::deprecate_stop("0.6.2", "splnr_convert_toPUs()", "spatialgridr::get_data_in_grid()") - } - - #' Plot MPAs #' #' `splnr_plot_MPAs()` allows to plot either the outline or the area of MPAs existing in the planning region (for example extracted with the `spatialplanr`function [splnr_get_MPAs()]) in a customisable way using `ggplot2`. This function requires an `sf` object containing the information whether a planning unit in the planning region lies within an MPA or not in a column called `wdpa` and outputs a `ggobject`. It can be combined with the `spatialplanr` function [splnr_gg_add()]. @@ -78,9 +72,7 @@ splnr_convert_toPUs <- function(dat, PlanUnits) { #' } splnr_plot_MPAs <- function(df, colorVals = c("TRUE" = "blue", "FALSE" = "white"), showLegend = TRUE, plotTitle = "Locked In Areas", legendTitle = "") { - lifecycle::deprecate_stop("0.6.2", "splnr_plot_MPAs()", "splnr_plot()") - } @@ -120,13 +112,10 @@ splnr_plot_MPAs <- function(df, colorVals = c("TRUE" = "blue", "FALSE" = "white" #' } splnr_plot_cost <- function(cost, costName = "Cost", legendTitle = "Cost", paletteName = "YlGnBu", plotTitle = "") { - lifecycle::deprecate_stop("0.6.2", "splnr_plot_MPAs()", "splnr_plot()") - } - #' Plot binary feature #' #' `splnr_plot_binFeature()` allows to plot presences and absences of a feature in the planning region in a customisable way using `ggplot2`. This function requires an `sf` object with binary information of a feature(`0` for absences and `1` for presences, for example created from continuous data with the `spatialplanr` function [splnr_apply_cutoffs()]). It outputs a `ggobject` and can be combined with the `spatialplanr` function [splnr_gg_add()]. @@ -150,9 +139,7 @@ splnr_plot_cost <- function(cost, costName = "Cost", legendTitle = "Cost", splnr_plot_binFeature <- function(df, colInterest, colorVals = c("Suitable" = "#3182bd", "Not Suitable" = "#c6dbef"), showLegend = TRUE, plotTitle = " ", legendTitle = "Habitat") { - lifecycle::deprecate_stop("0.6.2", "splnr_plot_binFeature()", "splnr_plot()") - } @@ -180,10 +167,5 @@ splnr_plot_binFeature <- function(df, colInterest, #' } splnr_plot_featureNo <- function(df, showLegend = TRUE, paletteName = "YlGnBu", plotTitle = "Number of Features", legendTitle = "Features") { - lifecycle::deprecate_stop("0.6.2", "splnr_plot_featureNo()", "splnr_plot()") - } - - - diff --git a/R/splnr_featureRep.R b/R/splnr_featureRep.R index 5576f314..36b668a7 100644 --- a/R/splnr_featureRep.R +++ b/R/splnr_featureRep.R @@ -193,7 +193,6 @@ splnr_get_featureRep <- function(soln, pDat, targets = NA, climsmartApproach = 0, solnCol = "solution_1", incidental_features = character(0)) { - # --- Input Assertions --- # Ensure 'soln' is an sf object and not empty. assertthat::assert_that( @@ -300,7 +299,7 @@ splnr_get_featureRep <- function(soln, pDat, targets = NA, ) %>% dplyr::group_by(.data$feature) %>% dplyr::summarise( - total_amount = sum(.data$total_amount, na.rm = TRUE), + total_amount = sum(.data$total_amount, na.rm = TRUE), absolute_held = sum(.data$absolute_held, na.rm = TRUE) ) %>% dplyr::ungroup() %>% @@ -310,12 +309,10 @@ splnr_get_featureRep <- function(soln, pDat, targets = NA, 0 )) %>% dplyr::left_join(targets, by = "feature") - } else if (climsmart == TRUE && climsmartApproach == 3) { # Percentile approach: join with pre-adjusted targets dataframe. s1 <- s1 %>% dplyr::left_join(targets, by = "feature") - } else { # Standard (non-climate-smart) approach: targets from the problem object. s1 <- s1 %>% @@ -368,7 +365,7 @@ splnr_get_featureRep <- function(soln, pDat, targets = NA, .data$absolute_held / .data$total_amount, 0 ), - target = 0, + target = 0, incidental = TRUE ) } else { @@ -505,7 +502,6 @@ splnr_plot_featureRep <- function(df, sort_by = "category", base_size = 14, ...) { - assertthat::assert_that( inherits(df, c("data.frame", "tbl_df")), is.logical(renameFeatures), @@ -775,7 +771,6 @@ splnr_plot_circBplot <- function(df, legend_color, legend_list, indicateTargets = TRUE, impTarget = NA, repTarget = NA, colTarget = "red", base_size = 14) { - # assertthat checks for initial inputs assertthat::assert_that( inherits(df, c("data.frame", "tbl_df")), @@ -907,14 +902,14 @@ splnr_plot_circBplot <- function(df, legend_color, legend_list, inherit.aes = FALSE ) + ggplot2::annotate("text", - x = rep(max(data$id - 1), 4), - y = c(25, 50, 75, 100), - label = c(25, 50, 75, 100), - color = "grey50", - size = 4, - angle = 0, # -5 - fontface = "bold", - hjust = 0.5 + x = rep(max(data$id - 1), 4), + y = c(25, 50, 75, 100), + label = c(25, 50, 75, 100), + color = "grey50", + size = 4, + angle = 0, # -5 + fontface = "bold", + hjust = 0.5 ) + # setting limitations of actual plot @@ -929,7 +924,6 @@ splnr_plot_circBplot <- function(df, legend_color, legend_list, fontface = "bold", alpha = 0.6, size = 2.5, angle = label_data$angle, inherit.aes = FALSE ) + - ggplot2::theme( legend.position = "bottom", axis.text = ggplot2::element_blank(), diff --git a/R/splnr_get_IUCNRedList.R b/R/splnr_get_IUCNRedList.R index 43bacf3c..cdd0e5f8 100644 --- a/R/splnr_get_IUCNRedList.R +++ b/R/splnr_get_IUCNRedList.R @@ -56,9 +56,11 @@ #' # For example: Sys.setenv(IUCN_REDLIST_KEY = "YOUR_API_KEY_HERE") #' #' # Example: Create a dataframe with species names and retrieve their IUCN Red List categories. -#' df_species_redlist <- data.frame(Species = c("Diomedea exulans", -#' "Hippocampus kuda", -#' "Squatina squatina")) %>% +#' df_species_redlist <- data.frame(Species = c( +#' "Diomedea exulans", +#' "Hippocampus kuda", +#' "Squatina squatina" +#' )) %>% #' splnr_get_IUCNRedList() #' print(df_species_redlist) #' @@ -68,7 +70,6 @@ #' print(df_alt_col) #' } splnr_get_IUCNRedList <- function(df, species_col = "Species") { - # Assertions to validate input parameters. assertthat::assert_that( inherits(df, "data.frame"), @@ -110,7 +111,7 @@ splnr_get_IUCNRedList <- function(df, species_col = "Species") { # Rename the selected columns to match the input dataframe's species column name # and a new column for the IUCN category for clarity. dplyr::rename(!!species_col := .data$result.scientific_name, - IUCN_Category = .data$category + IUCN_Category = .data$category ) # Perform a left join to link the species in the input dataframe to their diff --git a/R/splnr_get_MPAs.R b/R/splnr_get_MPAs.R index ed67a1fa..9e422daa 100644 --- a/R/splnr_get_MPAs.R +++ b/R/splnr_get_MPAs.R @@ -103,13 +103,12 @@ #' print(gg) #' } splnr_get_MPAs <- function(PlanUnits = NULL, - Countries, - Status = c("Designated", "Established", "Inscribed"), - Desig = c("National", "Regional", "International", "Not Applicable"), - Category = c("Ia", "Ib", "II", "III", "IV"), - Raw = FALSE, - ...) { - + Countries, + Status = c("Designated", "Established", "Inscribed"), + Desig = c("National", "Regional", "International", "Not Applicable"), + Category = c("Ia", "Ib", "II", "III", "IV"), + Raw = FALSE, + ...) { # Validate Raw argument first so subsequent guards can branch on it. assertthat::assert_that( is.logical(Raw) && length(Raw) == 1L && !is.na(Raw), @@ -171,9 +170,10 @@ splnr_get_MPAs <- function(PlanUnits = NULL, # Use purrr::map to fetch WDPA data for each country in the 'Countries' vector. # 'wait = TRUE' ensures sequential downloads, and 'download_dir' specifies where to cache the data. purrr::map(wdpar::wdpa_fetch, - wait = TRUE, - download_dir = rappdirs::user_data_dir("wdpar"), - ...) %>% + wait = TRUE, + download_dir = rappdirs::user_data_dir("wdpar"), + ... + ) %>% # Bind all fetched data frames into a single data frame. dplyr::bind_rows() %>% # Filter for marine and coastal protected areas only @@ -212,12 +212,16 @@ splnr_get_MPAs <- function(PlanUnits = NULL, # spatially constant" warning whenever an sf object with non-geometry columns # is intersected. We suppress only that specific message here. wdpa_data <- withCallingHandlers( - spatialgridr::get_data_in_grid(spatial_grid = PlanUnits, - dat = wdpa_data, - cutoff = 0.5), + spatialgridr::get_data_in_grid( + spatial_grid = PlanUnits, + dat = wdpa_data, + cutoff = 0.5 + ), warning = function(w) { if (grepl("attribute variables are assumed to be spatially constant", - conditionMessage(w), fixed = TRUE)) { + conditionMessage(w), + fixed = TRUE + )) { invokeRestart("muffleWarning") } } diff --git a/R/splnr_get_distCoast.R b/R/splnr_get_distCoast.R index 92f6273d..f2add491 100644 --- a/R/splnr_get_distCoast.R +++ b/R/splnr_get_distCoast.R @@ -59,7 +59,7 @@ #' ) #' #' if (exists("dat_sf") && exists("landmass")) { -#' # Transform landmass to the same CRS as the planning units +#' # Transform landmass to the same CRS as the planning units #' landmass_proj <- sf::st_transform(landmass, sf::st_crs(dat_sf)) #' dat_sf_custom_coast <- splnr_get_distCoast(dat_sf, custom_coast = landmass_proj) #' summary(dat_sf_custom_coast$coastDistance_km) diff --git a/R/splnr_get_gfw.R b/R/splnr_get_gfw.R index 6d8c24d3..70817f15 100644 --- a/R/splnr_get_gfw.R +++ b/R/splnr_get_gfw.R @@ -56,7 +56,7 @@ #' # Example: Retrieve yearly GFW data for Australia, transformed to a #' # Mollweide projection (ESRI:54009) and compressed (aggregated) by location. #' gfw_data <- splnr_get_gfw( -#' region = 'Australia', +#' region = "Australia", #' start_date = "2021-01-01", #' end_date = "2022-12-31", #' temp_res = "YEARLY", @@ -85,7 +85,6 @@ splnr_get_gfw <- function(region, key = gfwr::gfw_auth(), cCRS = "EPSG:4326", compress = FALSE) { - # Assertions for input parameters to ensure correct types and values assertthat::assert_that( (is.character(region) || is.numeric(region) || (region_source == "USER_SHAPEFILE" && inherits(region, "sf"))), @@ -108,7 +107,7 @@ splnr_get_gfw <- function(region, msg = "The 'spat_res' parameter must be one of 'LOW' or 'HIGH'." ) assertthat::assert_that( - region_source %in% c('EEZ', 'MPA', 'RFMO', 'USER_SHAPEFILE'), + region_source %in% c("EEZ", "MPA", "RFMO", "USER_SHAPEFILE"), msg = "The 'region_source' parameter must be one of 'EEZ', 'MPA', 'RFMO', or 'USER_SHAPEFILE'." ) assertthat::assert_that( @@ -125,18 +124,17 @@ splnr_get_gfw <- function(region, ) # Define an internal helper function to fetch GFW data for a single region. - get_gfw_byRegion <- function(region){ - + get_gfw_byRegion <- function(region) { # Determine the region ID based on the region_source and region type. - if (region_source == "EEZ" & is.character(region)){ + if (region_source == "EEZ" & is.character(region)) { region_id <- gfwr::gfw_region_id(region = region, region_source = region_source, key = key)$id - } else if (region_source == "EEZ" & is.numeric(region)){ + } else if (region_source == "EEZ" & is.numeric(region)) { # If region is numeric for EEZ, assume it's already an ID. region_id <- region - } else if (region_source == "RFMO"){ + } else if (region_source == "RFMO") { # For RFMO, pass the region as is; handles potential gfwr package quirks. region_id <- region - } else if (region_source == "USER_SHAPEFILE"){ + } else if (region_source == "USER_SHAPEFILE") { # If region_source is USER_SHAPEFILE, use the provided region (assumed to be an sf object). region_id <- region } @@ -147,24 +145,26 @@ splnr_get_gfw <- function(region, # Define a nested helper function to obtain data for a specific date range within the loop. get_data_for_range <- function(start_date, end_date, rid) { - # Call the gfwr::get_raster function to retrieve GFW raster data. data <- gfwr::gfw_ais_fishing_hours( spatial_resolution = spat_res, temporal_resolution = temp_res, - group_by = 'FLAGANDGEARTYPE', # Group by flag and geartype. + group_by = "FLAGANDGEARTYPE", # Group by flag and geartype. start_date = start_date, end_date = end_date, region = rid, region_source = region_source, - key = key) + key = key + ) # Mutate and rename columns for consistency and clarity. data <- data %>% dplyr::mutate(GFWregionID = rid) %>% # Add a column for the GFW region ID. - dplyr::rename(TimeRange = .data$`Time Range`, - VesselID = .data$`Vessel IDs`, - ApparentFishingHrs = .data$`Apparent Fishing Hours`) + dplyr::rename( + TimeRange = .data$`Time Range`, + VesselID = .data$`Vessel IDs`, + ApparentFishingHrs = .data$`Apparent Fishing Hours` + ) return(data) } @@ -183,18 +183,19 @@ splnr_get_gfw <- function(region, dplyr::bind_rows() # Check if the resulting data frame is empty and stop with an informative message if no data is found. - if(rlang::is_empty(data_df)){ + if (rlang::is_empty(data_df)) { stop(paste0("No data found at all for the requested area of ", region, " between ", start_date, " and ", end_date)) } # Process data based on the 'compress' parameter. - if (isTRUE(compress)){ - + if (isTRUE(compress)) { # Group data by Lon and Lat and summarise (sum) Apparent Fishing Hours for compression. data_df <- data_df %>% dplyr::group_by(.data$Lon, .data$Lat) %>% - dplyr::summarise("ApparentFishingHrs" = sum(.data$ApparentFishingHrs, na.rm = TRUE), - GFWregionID = dplyr::first(.data$GFWregionID)) %>% + dplyr::summarise( + "ApparentFishingHrs" = sum(.data$ApparentFishingHrs, na.rm = TRUE), + GFWregionID = dplyr::first(.data$GFWregionID) + ) %>% dplyr::ungroup() # Convert the aggregated data frame to a 'terra' raster, then to polygons, and finally to an 'sf' object. @@ -205,18 +206,16 @@ splnr_get_gfw <- function(region, dplyr::mutate(GFWregionID = as.factor(.data$GFWregionID)) # Ensure GFWregionID is a factor. # Verify that the dimensions of the data frame and sf object match after conversion. - if (dim(data_df)[1] != dim(data_sf)[1]){ + if (dim(data_df)[1] != dim(data_sf)[1]) { stop("Data dimensions of data_df and data_sf do not match after conversion to polygon") } - - } else if (isFALSE(compress)){ - + } else if (isFALSE(compress)) { # Process data without compression, separating 'TimeRange' based on temporal resolution. if (temp_res == "YEARLY") { # If temporal resolution is yearly, create a 'Year' column and convert to sf. data_sf <- data_df %>% dplyr::mutate(Year = .data$TimeRange) %>% - sf::st_as_sf(coords = c("Lon", "Lat"), crs ="EPSG:4326") + sf::st_as_sf(coords = c("Lon", "Lat"), crs = "EPSG:4326") } else { # Otherwise, separate 'TimeRange' into 'Year', 'Month', and/or 'Day' columns. if (temp_res == "MONTHLY") { @@ -232,7 +231,7 @@ splnr_get_gfw <- function(region, } # Transform the CRS of the sf object if the requested cCRS is different from the default "EPSG:4326". - if (isFALSE(cCRS == "EPSG:4326")){ + if (isFALSE(cCRS == "EPSG:4326")) { data_sf <- data_sf %>% sf::st_transform(crs = cCRS) } @@ -243,18 +242,20 @@ splnr_get_gfw <- function(region, out <- purrr::map(region, function(x) get_gfw_byRegion(x)) # Combine the results from multiple regions based on the 'compress' setting. - if (isFALSE(compress)){ + if (isFALSE(compress)) { # If not compressed, simply bind rows of the sf objects. out <- out %>% dplyr::bind_rows() - } else if (isTRUE(compress)){ + } else if (isTRUE(compress)) { # If compressed, bind rows and then re-summarise to handle duplicate cells on boundaries, # summing fishing hours and combining GFWregionIDs. out <- out %>% dplyr::bind_rows() %>% dplyr::group_by(.data$geometry) %>% - dplyr::summarise("ApparentFishingHrs" = sum(.data$ApparentFishingHrs, na.rm = TRUE), - GFWregionID = toString(.data$GFWregionID)) %>% + dplyr::summarise( + "ApparentFishingHrs" = sum(.data$ApparentFishingHrs, na.rm = TRUE), + GFWregionID = toString(.data$GFWregionID) + ) %>% dplyr::ungroup() } diff --git a/R/splnr_gg_add.R b/R/splnr_gg_add.R index 4ab2587f..fd5ccdd3 100644 --- a/R/splnr_gg_add.R +++ b/R/splnr_gg_add.R @@ -191,38 +191,57 @@ splnr_gg_add <- function(PUs = NULL, colorPUs = "grey80", labelLockOut = "", base_size = 14, ggtheme = "Default") { - # Assertions to validate input parameters are of the correct 'sf' class if not NULL. - if(!is.null(PUs)){assertthat::assert_that(inherits(PUs, "sf"), msg = "'PUs' must be an 'sf' object or NULL.")} - if(!is.null(Bndry)){assertthat::assert_that(inherits(Bndry, "sf"), msg = "'Bndry' must be an 'sf' object or NULL.")} - if(!is.null(overlay)){assertthat::assert_that(inherits(overlay, "sf"), msg = "'overlay' must be an 'sf' object or NULL.")} - if(!is.null(overlay2)){assertthat::assert_that(inherits(overlay2, "sf"), msg = "'overlay2' must be an 'sf' object or NULL.")} - if(!is.null(overlay3)){assertthat::assert_that(inherits(overlay3, "sf"), msg = "'overlay3' must be an 'sf' object or NULL.")} - if(!is.null(contours)){assertthat::assert_that(inherits(contours, "sf"), msg = "'contours' must be an 'sf' object or NULL.")} - if(!is.null(cropOverlay)){assertthat::assert_that(inherits(cropOverlay, "sf"), msg = "'cropOverlay' must be an 'sf' object or NULL.")} - + if (!is.null(PUs)) { + assertthat::assert_that(inherits(PUs, "sf"), msg = "'PUs' must be an 'sf' object or NULL.") + } + if (!is.null(Bndry)) { + assertthat::assert_that(inherits(Bndry, "sf"), msg = "'Bndry' must be an 'sf' object or NULL.") + } + if (!is.null(overlay)) { + assertthat::assert_that(inherits(overlay, "sf"), msg = "'overlay' must be an 'sf' object or NULL.") + } + if (!is.null(overlay2)) { + assertthat::assert_that(inherits(overlay2, "sf"), msg = "'overlay2' must be an 'sf' object or NULL.") + } + if (!is.null(overlay3)) { + assertthat::assert_that(inherits(overlay3, "sf"), msg = "'overlay3' must be an 'sf' object or NULL.") + } + if (!is.null(contours)) { + assertthat::assert_that(inherits(contours, "sf"), msg = "'contours' must be an 'sf' object or NULL.") + } + if (!is.null(cropOverlay)) { + assertthat::assert_that(inherits(cropOverlay, "sf"), msg = "'cropOverlay' must be an 'sf' object or NULL.") + } + # Validate lockIn parameters - if(!is.null(lockIn)){ + if (!is.null(lockIn)) { assertthat::assert_that(inherits(lockIn, "sf"), msg = "'lockIn' must be an 'sf' object or NULL.") assertthat::assert_that(is.character(nameLockIn) && !is.null(nameLockIn) && all(nameLockIn %in% names(lockIn)), - msg = "If 'lockIn' is provided, 'nameLockIn' must be a character string specifying an existing column in 'lockIn'.") + msg = "If 'lockIn' is provided, 'nameLockIn' must be a character string specifying an existing column in 'lockIn'." + ) assertthat::assert_that(typeLockIn %in% c("Full", "Contours"), - msg = "'typeLockIn' must be either 'Full' or 'Contours'.") + msg = "'typeLockIn' must be either 'Full' or 'Contours'." + ) assertthat::assert_that(is.numeric(alphaLockIn) && alphaLockIn >= 0 && alphaLockIn <= 1, - msg = "'alphaLockIn' must be a numeric value between 0 and 1.") + msg = "'alphaLockIn' must be a numeric value between 0 and 1." + ) } - + # Validate lockOut parameters - if(!is.null(lockOut)){ + if (!is.null(lockOut)) { assertthat::assert_that(inherits(lockOut, "sf"), msg = "'lockOut' must be an 'sf' object or NULL.") assertthat::assert_that(is.character(nameLockOut) && !is.null(nameLockOut) && all(nameLockOut %in% names(lockOut)), - msg = "If 'lockOut' is provided, 'nameLockOut' must be a character string specifying an existing column in 'lockOut'.") + msg = "If 'lockOut' is provided, 'nameLockOut' must be a character string specifying an existing column in 'lockOut'." + ) assertthat::assert_that(typeLockOut %in% c("Full", "Contours"), - msg = "'typeLockOut' must be either 'Full' or 'Contours'.") + msg = "'typeLockOut' must be either 'Full' or 'Contours'." + ) assertthat::assert_that(is.numeric(alphaLockOut) && alphaLockOut >= 0 && alphaLockOut <= 1, - msg = "'alphaLockOut' must be a numeric value between 0 and 1.") + msg = "'alphaLockOut' must be a numeric value between 0 and 1." + ) } - + # Validate color parameters assertthat::assert_that(is.character(colorPUs), msg = "'colorPUs' must be a character string for a color.") assertthat::assert_that(is.character(colorBndry), msg = "'colorBndry' must be a character string for a color.") @@ -232,13 +251,13 @@ splnr_gg_add <- function(PUs = NULL, colorPUs = "grey80", assertthat::assert_that(is.character(colorConts), msg = "'colorConts' must be a character string for a color.") assertthat::assert_that(is.character(colorLockIn), msg = "'colorLockIn' must be a character string for a color.") assertthat::assert_that(is.character(colorLockOut), msg = "'colorLockOut' must be a character string for a color.") - + # Validate legend and label parameters assertthat::assert_that(is.character(legendLockIn), msg = "'legendLockIn' must be a character string.") assertthat::assert_that(is.character(labelLockIn), msg = "'labelLockIn' must be a character string.") assertthat::assert_that(is.character(legendLockOut), msg = "'legendLockOut' must be a character string.") assertthat::assert_that(is.character(labelLockOut), msg = "'labelLockOut' must be a character string.") - + # Validate ggtheme parameter assertthat::assert_that( inherits(ggtheme, "character") || inherits(ggtheme, "theme") || inherits(ggtheme, "list") || inherits(ggtheme, "logical"), diff --git a/R/splnr_plot.R b/R/splnr_plot.R index 165dc975..7ad283f0 100644 --- a/R/splnr_plot.R +++ b/R/splnr_plot.R @@ -117,7 +117,6 @@ splnr_plot <- function(df, legendTitle = NULL, legendLabels = NULL, base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( is.data.frame(df), @@ -138,8 +137,10 @@ splnr_plot <- function(df, if (!is.null(colNames)) { assertthat::assert_that( all(colNames %in% colnames(df)), - msg = paste0("Not all specified 'colNames' exist in the input dataframe. Missing: ", - paste(colNames[!colNames %in% colnames(df)], collapse = ", ")) + msg = paste0( + "Not all specified 'colNames' exist in the input dataframe. Missing: ", + paste(colNames[!colNames %in% colnames(df)], collapse = ", ") + ) ) } assertthat::assert_that( @@ -171,29 +172,27 @@ splnr_plot <- function(df, showFeatureSum <- FALSE # Determine data type based on 'colNames' presence and content. - if (!is.null(colNames)){ # If 'colNames' are provided. + if (!is.null(colNames)) { # If 'colNames' are provided. - if (length(colNames) == 1){ # If only one column name is specified. + if (length(colNames) == 1) { # If only one column name is specified. - if (is.logical(df[[colNames]])){ # Check if the column data is logical (TRUE/FALSE). + if (is.logical(df[[colNames]])) { # Check if the column data is logical (TRUE/FALSE). is_logi <- TRUE } else { # If not logical, check if it's binary (0/1). # Create a temporary dataframe, replacing NA with 0 in the target columns for binary check. df0 <- df %>% - dplyr::mutate(dplyr::across(tidyselect::all_of(colNames), ~tidyr::replace_na(., 0))) + dplyr::mutate(dplyr::across(tidyselect::all_of(colNames), ~ tidyr::replace_na(., 0))) # Check if all values in the column are exclusively 0 or 1. is_binary <- all(purrr::map_vec(colNames, function(x) all(df0[[x]] %in% c(0, 1)))) } ## If not binary and not logical, assume it's continuous. - if (isFALSE(is_binary) & isFALSE(is_logi)){ + if (isFALSE(is_binary) & isFALSE(is_logi)) { is_continuous <- TRUE # This assumption allows plotting, and issues would be visible. } - - } else if (length(colNames) > 1){ # If multiple column names are specified. + } else if (length(colNames) > 1) { # If multiple column names are specified. showFeatureSum <- TRUE # Set flag to calculate and show the sum of features. } - } # Initialize the base ggplot object with coordinate system and subtitle. @@ -221,15 +220,16 @@ splnr_plot <- function(df, name = legendTitle, palette = paletteName, aesthetics = c("fill"), - oob = scales::squish) + + oob = scales::squish + ) + ggplot2::guides(fill = ggplot2::guide_colourbar(order = -1)) return(gg) } else if (is_binary | is_logi) { # If data is binary or logical. # Set default legend labels if not provided. - if (is.null(legendLabels)){ - legendLabels = c("Absence", "Presence") + if (is.null(legendLabels)) { + legendLabels <- c("Absence", "Presence") } # Add geom_sf for discrete fill based on the single column. @@ -241,19 +241,22 @@ splnr_plot <- function(df, # whether one or both levels (0/1) are present in the data. if (isTRUE(is_binary)) { gg <- gg + - ggplot2::scale_fill_manual(values = c("0" = colourVals[1], "1" = colourVals[2]), - labels = c("0" = legendLabels[1], "1" = legendLabels[2]), - name = legendTitle) + ggplot2::scale_fill_manual( + values = c("0" = colourVals[1], "1" = colourVals[2]), + labels = c("0" = legendLabels[1], "1" = legendLabels[2]), + name = legendTitle + ) } # Apply manual fill scale for logical (FALSE/TRUE) data. if (isTRUE(is_logi)) { gg <- gg + - ggplot2::scale_fill_manual(values = c("FALSE" = colourVals[1], "TRUE" = colourVals[2]), - labels = legendLabels, - name = legendTitle) + ggplot2::scale_fill_manual( + values = c("FALSE" = colourVals[1], "TRUE" = colourVals[2]), + labels = legendLabels, + name = legendTitle + ) } - } else if (is_continuous) { # If data is continuous. # Add geom_sf for continuous fill and color based on the single column. @@ -262,10 +265,11 @@ splnr_plot <- function(df, # Apply a viridis continuous color scale for fill and color. ggplot2::scale_fill_viridis_c(name = legendTitle, aesthetics = c("colour", "fill")) + # Configure guides to show color bar for fill and hide color legend for outline. - ggplot2::guides(fill = ggplot2::guide_colourbar(order = 1), - colour = "none") - - } else if (is.null(colNames)){ # If no column to plot by (only planning unit outlines). + ggplot2::guides( + fill = ggplot2::guide_colourbar(order = 1), + colour = "none" + ) + } else if (is.null(colNames)) { # If no column to plot by (only planning unit outlines). # Add geom_sf to display planning unit outlines without fill. gg <- gg + diff --git a/R/splnr_plotting.R b/R/splnr_plotting.R index e87131eb..82066b83 100644 --- a/R/splnr_plotting.R +++ b/R/splnr_plotting.R @@ -117,7 +117,6 @@ splnr_plot <- function(df, legendTitle = NULL, legendLabels = NULL, base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( is.data.frame(df), @@ -138,8 +137,10 @@ splnr_plot <- function(df, if (!is.null(colNames)) { assertthat::assert_that( all(colNames %in% colnames(df)), - msg = paste0("Not all specified 'colNames' exist in the input dataframe. Missing: ", - paste(colNames[!colNames %in% colnames(df)], collapse = ", ")) + msg = paste0( + "Not all specified 'colNames' exist in the input dataframe. Missing: ", + paste(colNames[!colNames %in% colnames(df)], collapse = ", ") + ) ) } assertthat::assert_that( @@ -171,29 +172,27 @@ splnr_plot <- function(df, showFeatureSum <- FALSE # Determine data type based on 'colNames' presence and content. - if (!is.null(colNames)){ # If 'colNames' are provided. + if (!is.null(colNames)) { # If 'colNames' are provided. - if (length(colNames) == 1){ # If only one column name is specified. + if (length(colNames) == 1) { # If only one column name is specified. - if (is.logical(df[[colNames]])){ # Check if the column data is logical (TRUE/FALSE). + if (is.logical(df[[colNames]])) { # Check if the column data is logical (TRUE/FALSE). is_logi <- TRUE } else { # If not logical, check if it's binary (0/1). # Create a temporary dataframe, replacing NA with 0 in the target columns for binary check. df0 <- df %>% - dplyr::mutate(dplyr::across(tidyselect::all_of(colNames), ~tidyr::replace_na(., 0))) + dplyr::mutate(dplyr::across(tidyselect::all_of(colNames), ~ tidyr::replace_na(., 0))) # Check if all values in the column are exclusively 0 or 1. is_binary <- all(purrr::map_vec(colNames, function(x) all(df0[[x]] %in% c(0, 1)))) } ## If not binary and not logical, assume it's continuous. - if (isFALSE(is_binary) & isFALSE(is_logi)){ + if (isFALSE(is_binary) & isFALSE(is_logi)) { is_continuous <- TRUE # This assumption allows plotting, and issues would be visible. } - - } else if (length(colNames) > 1){ # If multiple column names are specified. + } else if (length(colNames) > 1) { # If multiple column names are specified. showFeatureSum <- TRUE # Set flag to calculate and show the sum of features. } - } # Initialize the base ggplot object with coordinate system and subtitle. @@ -221,15 +220,16 @@ splnr_plot <- function(df, name = legendTitle, palette = paletteName, aesthetics = c("fill"), - oob = scales::squish) + + oob = scales::squish + ) + ggplot2::guides(fill = ggplot2::guide_colourbar(order = -1)) return(gg) } else if (is_binary | is_logi) { # If data is binary or logical. # Set default legend labels if not provided. - if (is.null(legendLabels)){ - legendLabels = c("Absence", "Presence") + if (is.null(legendLabels)) { + legendLabels <- c("Absence", "Presence") } # Add geom_sf for discrete fill based on the single column. @@ -239,19 +239,22 @@ splnr_plot <- function(df, # Apply manual fill scale for binary (0/1) data. if (isTRUE(is_binary)) { gg <- gg + - ggplot2::scale_fill_manual(values = c("0" = colourVals[1], "1" = colourVals[2]), - labels = legendLabels, - name = legendTitle) + ggplot2::scale_fill_manual( + values = c("0" = colourVals[1], "1" = colourVals[2]), + labels = legendLabels, + name = legendTitle + ) } # Apply manual fill scale for logical (FALSE/TRUE) data. if (isTRUE(is_logi)) { gg <- gg + - ggplot2::scale_fill_manual(values = c("FALSE" = colourVals[1], "TRUE" = colourVals[2]), - labels = legendLabels, - name = legendTitle) + ggplot2::scale_fill_manual( + values = c("FALSE" = colourVals[1], "TRUE" = colourVals[2]), + labels = legendLabels, + name = legendTitle + ) } - } else if (is_continuous) { # If data is continuous. # Add geom_sf for continuous fill and color based on the single column. @@ -260,10 +263,11 @@ splnr_plot <- function(df, # Apply a viridis continuous color scale for fill and color. ggplot2::scale_fill_viridis_c(name = legendTitle, aesthetics = c("colour", "fill")) + # Configure guides to show color bar for fill and hide color legend for outline. - ggplot2::guides(fill = ggplot2::guide_colourbar(order = 1), - colour = "none") - - } else if (is.null(colNames)){ # If no column to plot by (only Planning Unit outlines). + ggplot2::guides( + fill = ggplot2::guide_colourbar(order = 1), + colour = "none" + ) + } else if (is.null(colNames)) { # If no column to plot by (only Planning Unit outlines). # Add geom_sf to display Planning Unit outlines without fill. gg <- gg + @@ -588,7 +592,6 @@ splnr_plot_costOverlay <- function(soln, legendTitle = "Cost", plotTitle = "Solution overlaid with cost", base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(soln, "sf"), @@ -656,7 +659,7 @@ splnr_plot_costOverlay <- function(soln, oob = scales::squish, # Squish values outside the limits. guide = ggplot2::guide_colourbar( barwidth = ggplot2::unit(20, "lines"), # Twice the width of the climate colourbar (10 lines). - barheight = ggplot2::unit(6, "lines") # Twice the height of the climate colourbar (3 lines). + barheight = ggplot2::unit(6, "lines") # Twice the height of the climate colourbar (3 lines). ) ) + # Set coordinate limits based on the bounding box of the cost data. @@ -745,7 +748,6 @@ splnr_plot_costOverlay <- function(soln, #' } splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compared to Scenario 1:", base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(soln1, "sf"), @@ -789,9 +791,9 @@ splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compar # Categorize differences into "Same", "Removed (-)", or "Added (+)". dplyr::mutate( Compare = dplyr::case_when( - Combined == 2 ~ "Same", # Both selected. - solution_1 == 1 & solution_2 == 0 ~ "Removed (-)", # In soln1 only. - solution_1 == 0 & solution_2 == 1 ~ "Added (+)" # In soln2 only. + Combined == 2 ~ "Same", # Both selected. + solution_1 == 1 & solution_2 == 0 ~ "Removed (-)", # In soln1 only. + solution_1 == 0 & solution_2 == 1 ~ "Added (+)" # In soln2 only. ), Compare = factor(.data$Compare, levels = c("Added (+)", "Same", "Removed (-)")) ) %>% @@ -808,8 +810,10 @@ splnr_plot_comparison <- function(soln1, soln2, legendTitle = "Scenario 2 compar # Add sf layer for the comparison, filling by the 'Compare' factor. ggplot2::geom_sf(data = soln, ggplot2::aes(fill = .data$Compare), colour = NA, size = 0.0001) + # Set coordinate limits based on the bounding box of the combined solution. - ggplot2::coord_sf(xlim = c(bbox["xmin"], bbox["xmax"]), - ylim = c(bbox["ymin"], bbox["ymax"])) + + ggplot2::coord_sf( + xlim = c(bbox["xmin"], bbox["xmax"]), + ylim = c(bbox["ymin"], bbox["ymax"]) + ) + # Manually set fill colors for each comparison category. ggplot2::scale_fill_manual( name = legendTitle, # Set legend title. @@ -895,7 +899,6 @@ splnr_plot_selectionFreq <- function(selFreq, paletteName = "Greens", legendTitle = "Selection \nFrequency", base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(selFreq, "sf"), # Ensure selFreq is an sf object. @@ -1060,7 +1063,6 @@ splnr_plot_importanceScore <- function(soln, decimals = 4, legendTitle = "Importance Score", base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(soln, "sf"), # soln should be an sf object as it contains geometry @@ -1269,7 +1271,6 @@ splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#447 legendTitle = "Correlation \ncoefficient", AxisLabels = NULL, plotTitle = "", base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( is.matrix(x), @@ -1297,7 +1298,7 @@ splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#447 ) # Check if ggcorrplot package is installed, if not, stop with an error. - if (requireNamespace("ggcorrplot", quietly = TRUE) == FALSE){ + if (requireNamespace("ggcorrplot", quietly = TRUE) == FALSE) { stop("To run splnr_plot_corrMat you will need to install the package ggcorrplot.") } @@ -1305,9 +1306,9 @@ splnr_plot_corrMat <- function(x, colourGradient = c("#BB4444", "#FFFFFF", "#447 # Pass theme_bw(base_size) so that ggcorrplot's internal theme inherits the # correct base font size rather than its own hardcoded default. gg <- ggcorrplot::ggcorrplot(x, - outline.color = "black", # Set outline color for matrix cells. - lab = TRUE, # Display correlation coefficients on the plot. - ggtheme = ggplot2::theme_bw(base_size = base_size) + outline.color = "black", # Set outline color for matrix cells. + lab = TRUE, # Display correlation coefficients on the plot. + ggtheme = ggplot2::theme_bw(base_size = base_size) ) + # Apply a gradient fill for the correlation values. ggplot2::scale_fill_gradient2( diff --git a/R/splnr_plotting_climate.R b/R/splnr_plotting_climate.R index f9058a45..a1ef6464 100644 --- a/R/splnr_plotting_climate.R +++ b/R/splnr_plotting_climate.R @@ -1,4 +1,3 @@ - #' @title Plot Climate Metric Data #' #' @description @@ -70,7 +69,6 @@ splnr_plot_climData <- function(df, plotTitle = " ", legendTitle = "Climate metric", base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(df, "sf"), @@ -148,7 +146,6 @@ splnr_plot_climData <- function(df, #' @importFrom rlang .data := #' splnr_plot_climKernelDensity_Basic <- function(soln, base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(soln, "data.frame"), @@ -172,7 +169,7 @@ splnr_plot_climKernelDensity_Basic <- function(soln, base_size = 14) { ) # Check if ggridges package is installed, if not, stop with an error. - if (requireNamespace("ggridges", quietly = TRUE) == FALSE){ + if (requireNamespace("ggridges", quietly = TRUE) == FALSE) { stop("To run splnr_plot_climKernelDensity you will need to install the package ggridges.") } @@ -281,7 +278,6 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, legendTitle = expression(" \u00B0C y"^"-1" * ""), xAxisLab = expression("Climate warming ( \u00B0C y"^"-1" * ")"), base_size = 14) { - # --- Input validation ------------------------------------------------------- assertthat::assert_that( @@ -343,8 +339,10 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, df <- soln %>% tibble::as_tibble() %>% dplyr::select(tidyselect::all_of(c(solution_name, climate_name))) %>% - dplyr::rename(solution_1 = tidyselect::all_of(solution_name), - metric = tidyselect::all_of(climate_name)) %>% + dplyr::rename( + solution_1 = tidyselect::all_of(solution_name), + metric = tidyselect::all_of(climate_name) + ) %>% # A single-solution plot still needs a y-axis grouping variable for ggridges. # We use the climate column name as the label so the y-axis is informative # when the user inspects the raw plot object. @@ -355,10 +353,12 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, # remains self-contained and the lines always reflect the actual distribution. medians <- df %>% dplyr::group_by(.data$solution_1) %>% - dplyr::summarise(med = stats::median(.data$metric, na.rm = TRUE), - .groups = "drop") + dplyr::summarise( + med = stats::median(.data$metric, na.rm = TRUE), + .groups = "drop" + ) - med_selected <- medians$med[medians$solution_1 == 1] + med_selected <- medians$med[medians$solution_1 == 1] med_unselected <- medians$med[medians$solution_1 == 0] # Middle colour of the viridis palette — used as the representative fill @@ -380,9 +380,9 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, ) + # Viridis colour scale for the gradient fill (continuous legend). ggplot2::scale_fill_viridis_c( - name = legendTitle, + name = legendTitle, option = colorMap, - guide = ggplot2::guide_colorbar( + guide = ggplot2::guide_colorbar( barheight = ggplot2::unit(10, "lines"), barwidth = ggplot2::unit(3, "lines") ) @@ -421,13 +421,13 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, alpha = 0, na.rm = TRUE ) + ggplot2::scale_colour_manual( - name = NULL, + name = NULL, values = c("Selected PUs" = mid_colour, "Unselected PUs" = "grey70"), - guide = ggplot2::guide_legend( + guide = ggplot2::guide_legend( override.aes = list( fill = c(mid_colour, "grey70"), - colour = c("black", "black"), - linetype = c("solid", "dotted"), + colour = c("black", "black"), + linetype = c("solid", "dotted"), shape = 22, size = 8, alpha = 1 @@ -440,13 +440,13 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, ggplot2::theme_bw(base_size = base_size) + # Colour/layout overrides only; sizes inherit from base_size. ggplot2::theme( - axis.ticks = ggplot2::element_line(color = "black", linewidth = 1), - axis.line = ggplot2::element_line(colour = "black", linewidth = 1), - axis.text = ggplot2::element_text(color = "black"), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - legend.text = ggplot2::element_text(color = "black"), - legend.title = ggplot2::element_text(color = "black"), + axis.ticks = ggplot2::element_line(color = "black", linewidth = 1), + axis.line = ggplot2::element_line(colour = "black", linewidth = 1), + axis.text = ggplot2::element_text(color = "black"), + axis.title.y = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + legend.text = ggplot2::element_text(color = "black"), + legend.title = ggplot2::element_text(color = "black"), legend.title.position = "right" ) @@ -573,10 +573,14 @@ splnr_plot_climKernelDensity_Fancy <- function(soln, #' dplyr::mutate(solution_1 = sample(c(0L, 1L), dplyr::n(), replace = TRUE)) #' #' plot_compare <- patchwork::wrap_plots( -#' splnr_plot_climKernelDensity(soln = dat_solnClim, type = "Normal", -#' legendTitle = "Scenario 1", xAxisLab = "Climate metric"), -#' splnr_plot_climKernelDensity(soln = dat_solnClim_2, type = "Normal", -#' legendTitle = "Scenario 2", xAxisLab = "Climate metric"), +#' splnr_plot_climKernelDensity( +#' soln = dat_solnClim, type = "Normal", +#' legendTitle = "Scenario 1", xAxisLab = "Climate metric" +#' ), +#' splnr_plot_climKernelDensity( +#' soln = dat_solnClim_2, type = "Normal", +#' legendTitle = "Scenario 2", xAxisLab = "Climate metric" +#' ), #' ncol = 1 #' ) #' print(plot_compare) @@ -599,7 +603,6 @@ splnr_plot_climKernelDensity <- function(soln, legendTitle = expression(" \u00B0C y"^"-1" * ""), xAxisLab = expression("Climate warming ( \u00B0C y"^"-1" * ")"), base_size = 14) { - # Assertions to validate input parameters. assertthat::assert_that( is.character(type), diff --git a/R/splnr_targets.R b/R/splnr_targets.R index 2d398edb..f68a8bdb 100644 --- a/R/splnr_targets.R +++ b/R/splnr_targets.R @@ -62,7 +62,6 @@ #' print(targets_custom_range) #' } splnr_targets_byInverseArea <- function(df, target_min, target_max) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(df, "sf"), # Ensure df is an sf object. @@ -179,7 +178,6 @@ splnr_targets_byInverseArea <- function(df, target_min, target_max) { #' print(targets_by_type) #' } splnr_targets_byCategory <- function(dat, catTarg, catName = "Category") { - # Assertions to validate input parameters. assertthat::assert_that( inherits(dat, "data.frame"), # Ensure dat is a data.frame (or sf object). @@ -280,8 +278,10 @@ splnr_targets_byCategory <- function(dat, catTarg, catName = "Category") { #' # Example 1: Assigning specific targets to categories #' # Create a dummy dataframe resembling output from splnr_get_IUCNRedList #' df_species_iucn <- data.frame( -#' Species = c("Diomedea exulans", "Hippocampus kuda", -#' "Squatina squatina", "Common Dolphin"), +#' Species = c( +#' "Diomedea exulans", "Hippocampus kuda", +#' "Squatina squatina", "Common Dolphin" +#' ), #' IUCN_Category = c("VU", "EN", "CR", "LC") #' ) #' @@ -313,7 +313,6 @@ splnr_targets_byCategory <- function(dat, catTarg, catName = "Category") { #' print(df_updated_targets) #' } splnr_targets_byIUCN <- function(dat, IUCN_target, IUCN_col = "IUCN_Category") { - # Assertions to validate input parameters. assertthat::assert_that( inherits(dat, "data.frame"), # Ensure dat is a data.frame or sf object. @@ -348,14 +347,17 @@ splnr_targets_byIUCN <- function(dat, IUCN_target, IUCN_col = "IUCN_Category") { # If IUCN_target is a named vector, join and coalesce targets. dat <- dat %>% # Convert the named IUCN_target vector to a data frame for joining. - dplyr::left_join(data.frame(IUCN_target_value = IUCN_target, - IUCN_Category = names(IUCN_target)), - by = dplyr::join_by(!!rlang::sym(IUCN_col) == "IUCN_Category")) %>% + dplyr::left_join( + data.frame( + IUCN_target_value = IUCN_target, + IUCN_Category = names(IUCN_target) + ), + by = dplyr::join_by(!!rlang::sym(IUCN_col) == "IUCN_Category") + ) %>% # Use coalesce to update 'target' only where new IUCN_target_value is not NA. dplyr::mutate(target = dplyr::coalesce(.data$IUCN_target_value, .data$target)) %>% # Remove the temporary IUCN_target_value column. dplyr::select(-"IUCN_target_value") - } else if (is.numeric(IUCN_target) && length(IUCN_target) == 1) { # If IUCN_target is a single numeric, apply to specific threatened IUCN categories. dat <- dat %>% diff --git a/R/utils-climate.R b/R/utils-climate.R index 9b35c83b..2ea90c0d 100644 --- a/R/utils-climate.R +++ b/R/utils-climate.R @@ -91,7 +91,6 @@ splnr_climate_priorityArea_preprocess <- function(features, metric, direction, metric_col = "metric") { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." @@ -138,7 +137,7 @@ splnr_climate_priorityArea_preprocess <- function(features, joined_df <- sf::st_drop_geometry(features) joined_df[[".row_id"]] <- seq_len(nrow(joined_df)) joined_df <- dplyr::left_join(joined_df, metric_vals_df, by = ".row_id") - joined_df[[".row_id"]] <- NULL # remove key column; no trace in output + joined_df[[".row_id"]] <- NULL # remove key column; no trace in output if (any(is.na(joined_df$metric))) { warning( @@ -153,8 +152,8 @@ splnr_climate_priorityArea_preprocess <- function(features, result_list <- vector("list", length(spp)) for (i in seq_along(spp)) { - feat_col <- spp[i] - feat_vals <- joined_df[[feat_col]] + feat_col <- spp[i] + feat_vals <- joined_df[[feat_col]] metric_vals <- joined_df[["metric"]] # Indices where the feature is present AND metric is not NA. @@ -189,8 +188,8 @@ splnr_climate_priorityArea_preprocess <- function(features, # CS = feature present AND in climate-smart zone. # NCS = feature present AND NOT in climate-smart zone. # Both derived in one pass; no second loop or second join needed. - cs_col <- dplyr::if_else(feat_vals == 1, climate_smart, 0L) - ncs_col <- dplyr::if_else(feat_vals == 1, 1L - climate_smart, 0L) + cs_col <- dplyr::if_else(feat_vals == 1, climate_smart, 0L) + ncs_col <- dplyr::if_else(feat_vals == 1, 1L - climate_smart, 0L) result_list[[i]] <- data.frame(cs_col, ncs_col) names(result_list[[i]]) <- c( @@ -262,7 +261,6 @@ splnr_climate_priorityArea_preprocess <- function(features, splnr_climate_priorityArea_assignTargets <- function(targets, climateSmartDF, refugiaTarget = 1) { - assertthat::assert_that( is.data.frame(targets), msg = "'targets' must be a data.frame." @@ -285,7 +283,7 @@ splnr_climate_priorityArea_assignTargets <- function(targets, msg = "'refugiaTarget' must be a single numeric value between 0 and 1." ) assertthat::assert_that( - any(grepl("_CS$", names(climateSmartDF))) && + any(grepl("_CS$", names(climateSmartDF))) && any(grepl("_NCS$", names(climateSmartDF))), msg = paste0( "'climateSmartDF' must contain '_CS' and '_NCS' columns ", @@ -307,18 +305,20 @@ splnr_climate_priorityArea_assignTargets <- function(targets, ) finalList <- vector("list", length(spp)) - skipped <- 0L + skipped <- 0L for (i in seq_along(spp)) { - feat <- spp[i] - cs_name <- paste0(feat, "_CS") + feat <- spp[i] + cs_name <- paste0(feat, "_CS") ncs_name <- paste0(feat, "_NCS") - trgt <- targets %>% dplyr::filter(.data$feature == feat) %>% dplyr::pull("target") + trgt <- targets %>% + dplyr::filter(.data$feature == feat) %>% + dplyr::pull("target") # Use exact equality (not str_ends) to avoid substring-matching bugs # where e.g. "fish" would match "bluefish". - row_cs <- featDF[featDF$feature == cs_name, , drop = FALSE] + row_cs <- featDF[featDF$feature == cs_name, , drop = FALSE] row_ncs <- featDF[featDF$feature == ncs_name, , drop = FALSE] if (nrow(row_cs) == 0 || nrow(row_ncs) == 0) { @@ -330,7 +330,7 @@ splnr_climate_priorityArea_assignTargets <- function(targets, next } - n_cs <- row_cs[["planunit"]] + n_cs <- row_cs[["planunit"]] n_ncs <- row_ncs[["planunit"]] total <- n_cs + n_ncs @@ -343,12 +343,12 @@ splnr_climate_priorityArea_assignTargets <- function(targets, next } - prop_cs <- n_cs / total + prop_cs <- n_cs / total prop_ncs <- n_ncs / total if (prop_cs > trgt) { # All required representation can be met within CS areas alone. - targetCS <- trgt / prop_cs + targetCS <- trgt / prop_cs targetNCS <- 0 } else { targetCS <- refugiaTarget @@ -437,8 +437,8 @@ splnr_climate_priorityArea_assignTargets <- function(targets, #' percentile = 5, #' refugiaTarget = 1 #' ) -#' out_sf_cpa <- CPA_result$Features -#' targets_cpa <- CPA_result$Targets +#' out_sf_cpa <- CPA_result$Features +#' targets_cpa <- CPA_result$Targets #' } splnr_climate_priorityAreaApproach <- function(features, metric, @@ -447,7 +447,6 @@ splnr_climate_priorityAreaApproach <- function(features, percentile = 5, refugiaTarget = 1, metric_col = "metric") { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." @@ -579,7 +578,6 @@ splnr_climate_feature_preprocess <- function(features, metric, direction, metric_col = "metric") { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." @@ -647,7 +645,7 @@ splnr_climate_feature_preprocess <- function(features, features_df <- sf::st_drop_geometry(features) features_df[[".row_id"]] <- seq_len(nrow(features_df)) features_df <- dplyr::left_join(features_df, climate_col, by = ".row_id") - features_df[[".row_id"]] <- NULL # remove key column; no trace in output + features_df[[".row_id"]] <- NULL # remove key column; no trace in output features_out <- sf::st_set_geometry(features_df, sf::st_geometry(features)) %>% sf::st_as_sf() @@ -701,7 +699,6 @@ splnr_climate_feature_preprocess <- function(features, splnr_climate_feature_assignTargets <- function(climateSmartDF, refugiaTarget, targets) { - assertthat::assert_that( inherits(climateSmartDF, "data.frame"), msg = "'climateSmartDF' must be a data.frame or sf object." @@ -731,8 +728,8 @@ splnr_climate_feature_assignTargets <- function(climateSmartDF, msg = "'targets' must contain a 'target' column." ) - total_planning_units <- nrow(climateSmartDF) - total_climate_smart <- sum(climateSmartDF$climate_layer, na.rm = TRUE) + total_planning_units <- nrow(climateSmartDF) + total_climate_smart <- sum(climateSmartDF$climate_layer, na.rm = TRUE) if (total_planning_units == 0) { stop("'climateSmartDF' has no planning units. Cannot assign targets.") @@ -745,8 +742,8 @@ splnr_climate_feature_assignTargets <- function(climateSmartDF, trgt <- refugiaTarget / proportion_climate_smart climate_layerDF <- tibble::tribble( - ~feature, ~target, - "climate_layer", trgt + ~feature, ~target, + "climate_layer", trgt ) finalDF <- dplyr::bind_rows(targets, climate_layerDF) @@ -816,7 +813,7 @@ splnr_climate_feature_assignTargets <- function(climateSmartDF, #' percentile = 35, #' refugiaTarget = 0.3 #' ) -#' out_sf_feature <- Feature_result$Features +#' out_sf_feature <- Feature_result$Features #' targets_feature <- Feature_result$Targets #' } splnr_climate_featureApproach <- function(features, @@ -826,7 +823,6 @@ splnr_climate_featureApproach <- function(features, percentile = 35, refugiaTarget = 0.3, metric_col = "metric") { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." @@ -963,7 +959,6 @@ splnr_climate_percentile_preprocess <- function(features, percentile, direction, metric_col = "metric") { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." @@ -1016,7 +1011,7 @@ splnr_climate_percentile_preprocess <- function(features, joined_df <- sf::st_drop_geometry(features) joined_df[[".row_id"]] <- seq_len(nrow(joined_df)) joined_df <- dplyr::left_join(joined_df, metric_vals_df, by = ".row_id") - joined_df[[".row_id"]] <- NULL # remove key column; no trace in output + joined_df[[".row_id"]] <- NULL # remove key column; no trace in output # Percentile fraction is constant; compute once outside the loop. prct <- .splnr_climate_prct(percentile, direction) @@ -1024,8 +1019,8 @@ splnr_climate_percentile_preprocess <- function(features, percentileList <- vector("list", length(spp)) for (i in seq_along(spp)) { - feat_col <- spp[i] - feat_vals <- joined_df[[feat_col]] + feat_col <- spp[i] + feat_vals <- joined_df[[feat_col]] metric_vals <- joined_df[["metric"]] present_idx <- which(feat_vals == 1 & !is.na(metric_vals)) @@ -1111,7 +1106,6 @@ splnr_climate_percentile_preprocess <- function(features, splnr_climate_percentile_assignTargets <- function(features, climateSmartDF, targets) { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." @@ -1167,12 +1161,14 @@ splnr_climate_percentile_assignTargets <- function(features, dplyr::left_join(df_filt, by = "feature") %>% dplyr::mutate( proportion = dplyr::if_else(.data$original > 0, - .data$filtered / .data$original, 0), - target = dplyr::if_else(.data$proportion > 0, - .data$target / .data$proportion, - .data$target), + .data$filtered / .data$original, 0 + ), + target = dplyr::if_else(.data$proportion > 0, + .data$target / .data$proportion, + .data$target + ), # Cap at 1 (100%) to prevent infeasible targets. - target = dplyr::if_else(.data$target > 1, 1, .data$target) + target = dplyr::if_else(.data$target > 1, 1, .data$target) ) %>% dplyr::select("feature", "target") @@ -1239,7 +1235,7 @@ splnr_climate_percentile_assignTargets <- function(features, #' direction = 1, #' percentile = 35 #' ) -#' out_sf_percentile <- Percentile_result$Features +#' out_sf_percentile <- Percentile_result$Features #' targets_percentile <- Percentile_result$Targets #' } splnr_climate_percentileApproach <- function(features, @@ -1248,7 +1244,6 @@ splnr_climate_percentileApproach <- function(features, direction, percentile = 35, metric_col = "metric") { - assertthat::assert_that( inherits(features, "sf"), msg = "'features' must be an 'sf' object." diff --git a/R/utils.R b/R/utils.R index a0ff53db..589c77d5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,4 +1,3 @@ - ##### Utility Functions #### #' @title Create Spatial Polygon from Coordinates @@ -48,7 +47,6 @@ #' print(transformed_polygon) #' } splnr_create_polygon <- function(x, cCRS = "EPSG:4326") { - # Assertions to validate input parameters. assertthat::assert_that( inherits(x, "data.frame") && !is.null(x$x) && !is.null(x$y), @@ -135,7 +133,6 @@ splnr_create_polygon <- function(x, cCRS = "EPSG:4326") { #' print(sum(is.na(df_no_na$Spp2))) # Should be 0 if successful #' } splnr_replace_NAs <- function(df, vari) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(df, "sf"), # Ensure df is an sf object. @@ -156,7 +153,6 @@ splnr_replace_NAs <- function(df, vari) { # Check if there are any NA values in the specified variable. if (sum(is.na(dplyr::pull(df, !!rlang::sym(vari)))) > 0) { - # Add a unique row ID and a logical column 'isna' to identify NA rows. # This 'cellID' is crucial for reordering the dataframe correctly at the end. gp <- df %>% @@ -229,7 +225,6 @@ splnr_replace_NAs <- function(df, vari) { #' df_named_regions <- splnr_match_names(dat = dat_region, nam = region_names) #' print(df_named_regions) splnr_match_names <- function(dat, nam) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(dat, "sf"), @@ -304,6 +299,8 @@ splnr_match_names <- function(dat, nam) { #' #' @examples #' \dontrun{ +#' +#' } #' # Scale the 'Spp1' column. #' df_scaled_spp1 <- splnr_scale_01(dat = dat_species_prob, col_name = "Spp1") @@ -315,7 +312,6 @@ splnr_match_names <- function(dat, nam) { #' print(df_no_change) # Spp1 values should remain unchanged #' } splnr_scale_01 <- function(dat, col_name) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(dat, "sf"), # Ensure dat is an sf object. @@ -409,7 +405,6 @@ splnr_scale_01 <- function(dat, col_name) { #' # This function's primary use is to remove cost columns and potentially others. #' } splnr_featureNames <- function(dat, exclude = NA) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(dat, "sf"), @@ -474,6 +469,8 @@ splnr_featureNames <- function(dat, exclude = NA) { #' #' @examples #' \dontrun{ +#' +#' } #' print("Original order:") #' print(dat_species_prob) @@ -484,7 +481,6 @@ splnr_featureNames <- function(dat, exclude = NA) { #' print(df_arranged) #' } splnr_arrangeFeatures <- function(df) { - # Assertions to validate input parameters. assertthat::assert_that( inherits(df, "sf"), @@ -604,7 +600,6 @@ splnr_arrangeFeatures <- function(df) { #' # splnr_plot_corrMat(corrMat, AxisLabels = c("Sol A (30%)", "Sol B (50%)")) #' } splnr_get_kappaCorrData <- function(sol, name_sol) { - # Assertions to validate input parameters. assertthat::assert_that( is.list(sol), @@ -787,7 +782,6 @@ splnr_get_kappaCorrData <- function(sol, name_sol) { #' # You can then plot this: splnr_plot_selectionFreq(selFreq_list) #' } splnr_get_selFreq <- function(solnMany, type = "portfolio") { - # Assertions to validate input parameters. assertthat::assert_that( is.character(type) && length(type) == 1, @@ -812,14 +806,15 @@ splnr_get_selFreq <- function(solnMany, type = "portfolio") { # Calculate selection frequency for a portfolio (sf object with multiple solution columns). selFreq <- solnMany %>% # Convert to tibble for dplyr operations on columns, ensuring unique names. - dplyr::mutate(selFreq = as.factor(rowSums(dplyr::select(tibble::as_tibble(solnMany), - dplyr::starts_with("solution_")), na.rm = TRUE))) %>% + dplyr::mutate(selFreq = as.factor(rowSums(dplyr::select( + tibble::as_tibble(solnMany), + dplyr::starts_with("solution_") + ), na.rm = TRUE))) %>% # Convert back to sf, explicitly retaining the original geometry. sf::st_as_sf(geometry = sf::st_geometry(solnMany)) %>% # Select only the calculated selection frequency column. dplyr::select("selFreq") return(selFreq) - } else if (type == "list") { # If type is "list", expected input is a list of sf objects (individual solutions). assertthat::assert_that( diff --git a/data-raw/CreateHex.R b/data-raw/CreateHex.R index 09587ef1..da72f49a 100644 --- a/data-raw/CreateHex.R +++ b/data-raw/CreateHex.R @@ -35,12 +35,11 @@ create_hexagon <- function(center_x, center_y, size, top_type) { out <- list() for (i in 1:length(angles)) { - int <- sf::st_linestring(vertices[i:(i+1),]) %>% + int <- sf::st_linestring(vertices[i:(i + 1), ]) %>% sf::st_segmentize(units::set_units(0.1, km)) %>% sf::st_coordinates() - out[[i]] <- int[,1:2] - + out[[i]] <- int[, 1:2] } out2 <- list(do.call(rbind, out)) @@ -51,7 +50,7 @@ create_hexagon <- function(center_x, center_y, size, top_type) { return(polygon) } -Bndry <- create_hexagon(70, -5, 70*1.1547, "pointed") %>% +Bndry <- create_hexagon(70, -5, 70 * 1.1547, "pointed") %>% sf::st_polygon() %>% sf::st_sfc(crs = "EPSG:4326") %>% sf::st_sf() %>% @@ -75,35 +74,36 @@ PUs <- PUs %>% dplyr::mutate(Prob = runif(dim(PUs)[1])) (gg <- ggplot2::ggplot() + - ggplot2::geom_sf(data = PUs, colour = "#4F4F51", fill = "#46718C", linewidth = 0.1, show.legend = FALSE) + - ggplot2::geom_sf(data = landmass, colour = "grey70", fill = "#4F4F51", alpha = 1, linewidth = 0.05, show.legend = FALSE) + - ggplot2::coord_sf(xlim = sf::st_bbox(PUs)$xlim, ylim = sf::st_bbox(PUs)$ylim) + - ggplot2::theme_void()) + ggplot2::geom_sf(data = PUs, colour = "#4F4F51", fill = "#46718C", linewidth = 0.1, show.legend = FALSE) + + ggplot2::geom_sf(data = landmass, colour = "grey70", fill = "#4F4F51", alpha = 1, linewidth = 0.05, show.legend = FALSE) + + ggplot2::coord_sf(xlim = sf::st_bbox(PUs)$xlim, ylim = sf::st_bbox(PUs)$ylim) + + ggplot2::theme_void()) hexSticker::sticker(gg, - package = "spatialplanr", - p_x = 1, - p_y = 0.98, - p_color = "white", - p_family = "Aller_Rg", - p_fontface = "bold", - p_size = 80, - s_x = 1, - s_y = 1, - s_width = 2.2, - s_height = 2.2, - # h_fill = "#9FE2BF", - h_color = "black", # "grey40", - url = "spatialplanning.github.io/spatialplanr", - u_color = "grey90", - # u_family = "sans", - u_size = 15, - u_x = 0.98, - u_y = 0.055, - dpi = 1000, - asp = 1, - filename = file.path("data-raw", "spatialplanr.png")) + package = "spatialplanr", + p_x = 1, + p_y = 0.98, + p_color = "white", + p_family = "Aller_Rg", + p_fontface = "bold", + p_size = 80, + s_x = 1, + s_y = 1, + s_width = 2.2, + s_height = 2.2, + # h_fill = "#9FE2BF", + h_color = "black", # "grey40", + url = "spatialplanning.github.io/spatialplanr", + u_color = "grey90", + # u_family = "sans", + u_size = 15, + u_x = 0.98, + u_y = 0.055, + dpi = 1000, + asp = 1, + filename = file.path("data-raw", "spatialplanr.png") +) usethis::use_logo(img = file.path("data-raw", "spatialplanr.png")) diff --git a/data-raw/DATASET.R b/data-raw/DATASET.R index b0369867..173baee2 100644 --- a/data-raw/DATASET.R +++ b/data-raw/DATASET.R @@ -73,7 +73,7 @@ dat_mpas <- dat_PUs %>% dplyr::mutate(wdpa = ifelse((cellID > 33 & cellID < 38) | (cellID > 63 & cellID < 68) | (cellID > 93 & cellID < 98), 1, 0)) %>% - dplyr::select(-"cellID") + dplyr::select(-"cellID") # Add a problem object @@ -121,10 +121,11 @@ dat_clim <- dat_PUs %>% sf::st_sf() %>% dplyr::mutate(metric = climVec) -dat_bathy <- oceandatr::get_bathymetry(spatial_grid = dat_PUs, - keep = FALSE, - classify_bathymetry = FALSE) - +dat_bathy <- oceandatr::get_bathymetry( + spatial_grid = dat_PUs, + keep = FALSE, + classify_bathymetry = FALSE +) # The three datasets below are loaded from pre-existing .rda files rather than diff --git a/data-raw/splnr_Create_SinglePolygon.R b/data-raw/splnr_Create_SinglePolygon.R index 435dbb47..718b21de 100644 --- a/data-raw/splnr_Create_SinglePolygon.R +++ b/data-raw/splnr_Create_SinglePolygon.R @@ -1,4 +1,3 @@ - # Create one polygon that we can use to populate with PUs # # splnr_Create_SinglePolygon <- function (df, res){ @@ -19,4 +18,3 @@ # dplyr::select(.data$layer) %>% # dplyr::summarise(total_layer = sum(.data$layer, do_union = TRUE)) # } - diff --git a/data-raw/splnr_convert_toPacific.R b/data-raw/splnr_convert_toPacific.R index bfa816f6..3a563168 100644 --- a/data-raw/splnr_convert_toPacific.R +++ b/data-raw/splnr_convert_toPacific.R @@ -1,4 +1,3 @@ - #' Convert a world sf object to a Pacific-centred one #' Defaults to assuming Robinson projection #' @@ -19,7 +18,6 @@ splnr_convert_toPacific <- function(df, buff = 0, cCRS) { - assertthat::assert_that( inherits(df, "sf"), is.numeric(buff) && buff >= 0, diff --git a/data-raw/testOptimalityGap.R b/data-raw/testOptimalityGap.R index 439e0e00..c49b3b17 100644 --- a/data-raw/testOptimalityGap.R +++ b/data-raw/testOptimalityGap.R @@ -1,26 +1,28 @@ ## Test time of # of features vs gap penalty vs PU number gap_range <- c(0.01, 0.02, 0.03, 0.04, 0.05, 0.1, 0.2, 0.3, 0.5, 0.8) -feature_num <- c(50, 100, 500, 1000, 5000, 10000)#, 50000)#, 100000) +feature_num <- c(50, 100, 500, 1000, 5000, 10000) # , 50000)#, 100000) -mat1 = matrix(, nrow = length(feature_num)*length(gap_range), ncol = 3) -counter = 1 +mat1 <- matrix(, nrow = length(feature_num) * length(gap_range), ncol = 3) +counter <- 1 for (j in 1:length(feature_num)) { for (i in 1:length(gap_range)) { - print(counter) - spp_names <- purrr::map_chr(1:feature_num[j], ~paste0("spp", .)) + spp_names <- purrr::map_chr(1:feature_num[j], ~ paste0("spp", .)) dat_species <- dat_PUs %>% - dplyr::bind_cols(setNames(purrr::map(1:feature_num[j], ~rbinom(nrow(dat_PUs), 1, 0.5)), - spp_names)) %>% + dplyr::bind_cols(setNames( + purrr::map(1:feature_num[j], ~ rbinom(nrow(dat_PUs), 1, 0.5)), + spp_names + )) %>% sf::st_sf() dat_problem <- prioritizr::problem(dat_species %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = spp_names, - cost_column = "Cost") %>% + features = spp_names, + cost_column = "Cost" + ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% prioritizr::add_binary_decisions() %>% @@ -31,14 +33,12 @@ for (j in 1:length(feature_num)) { runTime <- attr(dat_soln, "runtime")[[1]] - mat1[counter,1] = gap_range[i] - mat1[counter,2] = feature_num[j] - mat1[counter,3] = runTime - - counter = counter + 1 + mat1[counter, 1] <- gap_range[i] + mat1[counter, 2] <- feature_num[j] + mat1[counter, 3] <- runTime + counter <- counter + 1 } - } feature_gap <- data.frame(mat1) @@ -65,31 +65,32 @@ Bndry <- dplyr::tibble(x = 60, y = seq(-60, 0, by = 1)) %>% PUs <- sf::st_make_grid(Bndry, cellsize = 0.125) %>% sf::st_sf() -feature_num <- c(25, 50, 100, 500)#, 1000)#, 5000, 10000)#, 50000, 100000) -PU_cellsize <- c(2,1,0.5,0.25,0.125) +feature_num <- c(25, 50, 100, 500) # , 1000)#, 5000, 10000)#, 50000, 100000) +PU_cellsize <- c(2, 1, 0.5, 0.25, 0.125) -mat2 = matrix(, nrow = length(feature_num)*length(PU_cellsize), ncol = 3) -counter = 1 +mat2 <- matrix(, nrow = length(feature_num) * length(PU_cellsize), ncol = 3) +counter <- 1 for (k in 1:length(PU_cellsize)) { - PUs <- sf::st_make_grid(Bndry, cellsize = PU_cellsize[k]) %>% sf::st_sf() for (j in 1:length(feature_num)) { - print(counter) - spp_names <- purrr::map_chr(1:feature_num[j], ~paste0("spp", .)) + spp_names <- purrr::map_chr(1:feature_num[j], ~ paste0("spp", .)) dat_species <- PUs %>% - dplyr::bind_cols(setNames(purrr::map(1:feature_num[j], ~rbinom(nrow(PUs), 1, 0.5)), - spp_names)) %>% + dplyr::bind_cols(setNames( + purrr::map(1:feature_num[j], ~ rbinom(nrow(PUs), 1, 0.5)), + spp_names + )) %>% sf::st_sf() dat_problem <- prioritizr::problem(dat_species %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = spp_names, - cost_column = "Cost") %>% + features = spp_names, + cost_column = "Cost" + ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% prioritizr::add_binary_decisions() %>% @@ -100,14 +101,12 @@ for (k in 1:length(PU_cellsize)) { runTime <- attr(dat_soln, "runtime")[[1]] - mat2[counter,1] = PU_cellsize[k] - mat2[counter,2] = feature_num[j] - mat2[counter,3] = runTime - - counter = counter + 1 + mat2[counter, 1] <- PU_cellsize[k] + mat2[counter, 2] <- feature_num[j] + mat2[counter, 3] <- runTime + counter <- counter + 1 } - } feature_PUs <- data.frame(mat2) @@ -115,36 +114,36 @@ colnames(feature_PUs) <- c("PUNumber", "FeatureNumber", "Runtime") saveRDS(feature_PUs, "feature_PUs.rds") -#features, PUs and optimalty gap +# features, PUs and optimalty gap gap_range <- c(0.01, 0.03, 0.05, 0.1, 0.2, 0.3, 0.5, 0.8) -feature_num <- c(25, 50)#, 100, 500) +feature_num <- c(25, 50) # , 100, 500) -PU_cellsize <- c(2,1,0.5,0.25,0.125) +PU_cellsize <- c(2, 1, 0.5, 0.25, 0.125) -mat3 = matrix(, nrow = length(gap_range)*length(PU_cellsize)*length(feature_num), ncol = 4) -counter = 1 +mat3 <- matrix(, nrow = length(gap_range) * length(PU_cellsize) * length(feature_num), ncol = 4) +counter <- 1 for (k in 1:length(PU_cellsize)) { - PUs <- sf::st_make_grid(Bndry, cellsize = PU_cellsize[k]) %>% sf::st_sf() for (j in 1:length(feature_num)) { - for (i in 1:length(gap_range)) { - print(counter) - spp_names <- purrr::map_chr(1:feature_num[j], ~paste0("spp", .)) + spp_names <- purrr::map_chr(1:feature_num[j], ~ paste0("spp", .)) dat_species <- PUs %>% - dplyr::bind_cols(setNames(purrr::map(1:feature_num[j], ~rbinom(nrow(PUs), 1, 0.5)), - spp_names)) %>% + dplyr::bind_cols(setNames( + purrr::map(1:feature_num[j], ~ rbinom(nrow(PUs), 1, 0.5)), + spp_names + )) %>% sf::st_sf() dat_problem <- prioritizr::problem(dat_species %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = spp_names, - cost_column = "Cost") %>% + features = spp_names, + cost_column = "Cost" + ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% prioritizr::add_binary_decisions() %>% @@ -155,20 +154,18 @@ for (k in 1:length(PU_cellsize)) { runTime <- attr(dat_soln, "runtime")[[1]] - mat3[counter,1] = nrow(PUs) - mat3[counter,2] = feature_num[j] - mat3[counter,3] = gap_range[i] - mat3[counter,4] = runTime + mat3[counter, 1] <- nrow(PUs) + mat3[counter, 2] <- feature_num[j] + mat3[counter, 3] <- gap_range[i] + mat3[counter, 4] <- runTime - counter = counter + 1 + counter <- counter + 1 } } - } feature_PUs_gap <- data.frame(mat3) -colnames(feature_PUs_gap) <- c("PUNumber", "FeatureNumber", "OptimalityGap","Runtime") - +colnames(feature_PUs_gap) <- c("PUNumber", "FeatureNumber", "OptimalityGap", "Runtime") saveRDS(feature_PUs_gap, "feature_PUs_gap.rds") @@ -176,39 +173,40 @@ saveRDS(feature_PUs_gap, "feature_PUs_gap.rds") gc() gc() -#penalty and optimalty gap +# penalty and optimalty gap gap_range <- c(0.1, 0.2, 0.3, 0.5, 0.8) feature_num <- c(25, 50) -PU_cellsize <- c(2,1,0.5)#,0.25)#,0.125) -penalty_range <- c(1)#,2, 0.5, 0.1) +PU_cellsize <- c(2, 1, 0.5) # ,0.25)#,0.125) +penalty_range <- c(1) # ,2, 0.5, 0.1) -mat4 = matrix(, nrow = length(gap_range)*length(PU_cellsize)*length(feature_num)*length(penalty_range), - ncol = 5) -counter = 1 +mat4 <- matrix(, + nrow = length(gap_range) * length(PU_cellsize) * length(feature_num) * length(penalty_range), + ncol = 5 +) +counter <- 1 for (k in 1:length(PU_cellsize)) { - PUs <- sf::st_make_grid(Bndry, cellsize = PU_cellsize[k]) %>% sf::st_sf() for (j in 1:length(feature_num)) { - for (i in 1:length(gap_range)) { - - spp_names <- purrr::map_chr(1:feature_num[j], ~paste0("spp", .)) + spp_names <- purrr::map_chr(1:feature_num[j], ~ paste0("spp", .)) dat_species <- PUs %>% - dplyr::bind_cols(setNames(purrr::map(1:feature_num[j], ~rbinom(nrow(PUs), 1, 0.5)), - spp_names)) %>% + dplyr::bind_cols(setNames( + purrr::map(1:feature_num[j], ~ rbinom(nrow(PUs), 1, 0.5)), + spp_names + )) %>% sf::st_sf() for (l in 1:length(penalty_range)) { - print(counter) dat_problem <- prioritizr::problem(dat_species %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = spp_names, - cost_column = "Cost") %>% + features = spp_names, + cost_column = "Cost" + ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% prioritizr::add_boundary_penalties(penalty_range[l]) %>% @@ -220,38 +218,37 @@ for (k in 1:length(PU_cellsize)) { runTime <- attr(dat_soln, "runtime")[[1]] - mat4[counter,1] = nrow(PUs) - mat4[counter,2] = feature_num[j] - mat4[counter,3] = gap_range[i] - mat4[counter,4] = penalty_range[l] - mat4[counter,5] = runTime + mat4[counter, 1] <- nrow(PUs) + mat4[counter, 2] <- feature_num[j] + mat4[counter, 3] <- gap_range[i] + mat4[counter, 4] <- penalty_range[l] + mat4[counter, 5] <- runTime print("here") saveRDS(mat4, "mat4.rds") - counter = counter + 1 - + counter <- counter + 1 } } } } feat_PUs_gap_penalty <- data.frame(mat4) -colnames(feat_PUs_gap_penalty) <- c("PUNumber", "FeatureNumber", - "OptimalityGap", "BoundaryPenalty", "Runtime") +colnames(feat_PUs_gap_penalty) <- c( + "PUNumber", "FeatureNumber", + "OptimalityGap", "BoundaryPenalty", "Runtime" +) saveRDS(feat_PUs_gap_penalty, "feat_PUs_gap_penalty.rds") +# hexagonal vs square PUs in large problems +# zones vs no zones -#hexagonal vs square PUs in large problems - -#zones vs no zones - -#objective functions differences +# objective functions differences -#adding constraints differences +# adding constraints differences -#raster vs shape file +# raster vs shape file diff --git a/tests/testthat/test-splnr_apply_cutoffs.R b/tests/testthat/test-splnr_apply_cutoffs.R index 0d90ecc2..7be79f10 100644 --- a/tests/testthat/test-splnr_apply_cutoffs.R +++ b/tests/testthat/test-splnr_apply_cutoffs.R @@ -1,4 +1,3 @@ - # Helper used across multiple tests: get numeric column names from an sf result, # excluding geometry. Uses the same purrr::map_lgl approach as the function itself. get_numeric_cols <- function(sf_obj) { @@ -35,25 +34,25 @@ testthat::test_that("named numeric vector cutoff returns an sf object", { # --- Single numeric scalar: correct binarisation --- testthat::test_that("single numeric cutoff produces only 0/1 values", { - result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0.5) - num_cols <- get_numeric_cols(result) - vals <- unlist(sf::st_drop_geometry(result)[num_cols]) + result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0.5) + num_cols <- get_numeric_cols(result) + vals <- unlist(sf::st_drop_geometry(result)[num_cols]) expect_true(all(vals %in% c(0, 1))) }) testthat::test_that("single numeric cutoff: values >= threshold become 1", { # Cutoff of 0 means every non-NA value (>= 0) becomes 1. - result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0) + result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0) num_cols <- get_numeric_cols(result) - vals <- unlist(sf::st_drop_geometry(result)[num_cols]) + vals <- unlist(sf::st_drop_geometry(result)[num_cols]) expect_true(all(vals == 1)) }) testthat::test_that("single numeric cutoff: values < threshold become 0", { # Cutoff of 1 means only values exactly equal to 1 become 1; all others become 0. - result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 1) + result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 1) num_cols <- get_numeric_cols(result) - vals <- unlist(sf::st_drop_geometry(result)[num_cols]) + vals <- unlist(sf::st_drop_geometry(result)[num_cols]) expect_true(all(vals %in% c(0, 1))) }) @@ -61,14 +60,14 @@ testthat::test_that("inverse flips 0 and 1 for non-NA values", { # NA values become 0 in normal mode and 1 in inverse mode (0 is binarised # first, then flipped), so they do not sum to 1. We therefore test only on # non-NA cells in the original data. - normal <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0.5, inverse = FALSE) + normal <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0.5, inverse = FALSE) inverted <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = 0.5, inverse = TRUE) num_cols <- get_numeric_cols(normal) for (col in num_cols) { - orig_vals <- sf::st_drop_geometry(dat_species_prob)[[col]] - non_na_idx <- !is.na(orig_vals) - normal_vals <- sf::st_drop_geometry(normal)[[col]][non_na_idx] + orig_vals <- sf::st_drop_geometry(dat_species_prob)[[col]] + non_na_idx <- !is.na(orig_vals) + normal_vals <- sf::st_drop_geometry(normal)[[col]][non_na_idx] inverse_vals <- sf::st_drop_geometry(inverted)[[col]][non_na_idx] expect_equal(normal_vals + inverse_vals, rep(1, sum(non_na_idx))) } @@ -84,9 +83,9 @@ testthat::test_that("single function cutoff returns an sf object", { }) testthat::test_that("single function cutoff produces only 0/1 values", { - result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = \(x) quantile(x, 0.99)) + result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = \(x) quantile(x, 0.99)) num_cols <- get_numeric_cols(result) - vals <- unlist(sf::st_drop_geometry(result)[num_cols]) + vals <- unlist(sf::st_drop_geometry(result)[num_cols]) expect_true(all(vals %in% c(0, 1))) }) @@ -98,9 +97,9 @@ testthat::test_that("single function cutoff with inverse returns an sf object", }) testthat::test_that("single function cutoff: median threshold produces only 0/1 values", { - result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = \(x) median(x)) + result <- splnr_apply_cutoffs(dat_species_prob, Cutoffs = \(x) median(x)) num_cols <- get_numeric_cols(result) - vals <- unlist(sf::st_drop_geometry(result)[num_cols]) + vals <- unlist(sf::st_drop_geometry(result)[num_cols]) expect_true(all(vals %in% c(0, 1))) }) @@ -120,7 +119,7 @@ testthat::test_that("named list with mixed numeric and function entries returns }) testthat::test_that("named list cutoff produces only 0/1 values in targeted columns", { - result <- splnr_apply_cutoffs( + result <- splnr_apply_cutoffs( dat_species_prob, Cutoffs = list( "Spp1" = 0.5, @@ -140,7 +139,7 @@ testthat::test_that("named list: untargeted columns are unchanged", { ) # Spp2 should be unchanged (still continuous) original_spp2 <- sf::st_drop_geometry(dat_species_prob)[["Spp2"]] - result_spp2 <- sf::st_drop_geometry(result)[["Spp2"]] + result_spp2 <- sf::st_drop_geometry(result)[["Spp2"]] expect_equal(original_spp2, result_spp2) }) diff --git a/tests/testthat/test-splnr_featureRep.R b/tests/testthat/test-splnr_featureRep.R index 98a74361..1bbcc24d 100644 --- a/tests/testthat/test-splnr_featureRep.R +++ b/tests/testthat/test-splnr_featureRep.R @@ -1,6 +1,6 @@ pDat <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = c("Spp1", "Spp2", "Spp3"), - cost_column = "Cost" + features = c("Spp1", "Spp2", "Spp3"), + cost_column = "Cost" ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% @@ -23,8 +23,10 @@ testthat::test_that("splnr_get_featureRep() returns a tibble for basic use", { testthat::test_that("splnr_get_featureRep() returns correct columns", { df <- splnr_get_featureRep(soln = soln, pDat = pDat) - expect_true(all(c("feature", "total_amount", "absolute_held", - "relative_held", "target", "incidental") %in% names(df))) + expect_true(all(c( + "feature", "total_amount", "absolute_held", + "relative_held", "target", "incidental" + ) %in% names(df))) }) @@ -77,7 +79,7 @@ testthat::test_that("splnr_get_featureRep() errors when incidental_features over splnr_get_featureRep( soln = soln, pDat = pDat, - incidental_features = c("Spp1") # Spp1 is already in pDat + incidental_features = c("Spp1") # Spp1 is already in pDat ), regexp = "already features in 'pDat'" ) @@ -88,14 +90,13 @@ testthat::test_that("splnr_plot_featureRep() returns a ggplot for basic use", { expect_s3_class( splnr_plot_featureRep(splnr_get_featureRep( soln = soln, - pDat = pDat), category = dat_category) - , "gg" + pDat = pDat + ), category = dat_category), + "gg" ) }) - - testthat::test_that("Correct function output", { s1 <- soln %>% tibble::as_tibble() @@ -111,10 +112,10 @@ testthat::test_that("Correct function output", { target <- data.frame(feature = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5")) %>% dplyr::mutate(class = dplyr::if_else(.data$feature %in% imp_layers, - "important", "representative" + "important", "representative" )) %>% dplyr::mutate(target = dplyr::if_else(class == "important", - 50 / 100, 30 / 100 + 50 / 100, 30 / 100 )) df <- merge(df_rep_imp, target) %>% @@ -131,10 +132,11 @@ testthat::test_that("Correct function output", { expect_s3_class( (splnr_plot_circBplot(df, - legend_list = legends, - legend_color = colors, - impTarget = 50, repTarget = 30)) - , "gg" + legend_list = legends, + legend_color = colors, + impTarget = 50, repTarget = 30 + )), + "gg" ) }) @@ -216,8 +218,10 @@ testthat::test_that("splnr_get_featureRep() works with climsmart=TRUE, climsmart # Should return one row per original feature (not per CS/NCS split) expect_s3_class(df, "tbl_df") expect_equal(nrow(df), nrow(targets_df)) - expect_true(all(c("feature", "total_amount", "absolute_held", - "relative_held", "target") %in% names(df))) + expect_true(all(c( + "feature", "total_amount", "absolute_held", + "relative_held", "target" + ) %in% names(df))) }) @@ -263,8 +267,10 @@ testthat::test_that("splnr_get_featureRep() works with climsmart=TRUE, climsmart expect_s3_class(df, "tbl_df") expect_equal(nrow(df), nrow(targets_df)) - expect_true(all(c("feature", "total_amount", "absolute_held", - "relative_held", "target") %in% names(df))) + expect_true(all(c( + "feature", "total_amount", "absolute_held", + "relative_held", "target" + ) %in% names(df))) }) @@ -312,4 +318,3 @@ testthat::test_that("splnr_plot_featureRep() works with categoryFeatureCol when "gg" ) }) - diff --git a/tests/testthat/test-splnr_get_MPAs.R b/tests/testthat/test-splnr_get_MPAs.R index aea7d934..d06a42ac 100644 --- a/tests/testthat/test-splnr_get_MPAs.R +++ b/tests/testthat/test-splnr_get_MPAs.R @@ -1,4 +1,3 @@ - testthat::test_that("Raw = FALSE (default) returns an sf object of planning units", { testthat::expect_s3_class( splnr_get_MPAs(dat_PUs, "Australia"), "sf" diff --git a/tests/testthat/test-splnr_get_boundary.R b/tests/testthat/test-splnr_get_boundary.R index edd6fd5a..bb0b1e88 100644 --- a/tests/testthat/test-splnr_get_boundary.R +++ b/tests/testthat/test-splnr_get_boundary.R @@ -1,16 +1,18 @@ - testthat::test_that("Correct function output", { - expect_s3_class( - splnr_get_boundary("North Atlantic Ocean", "Ocean"), "sf") + expect_s3_class( + splnr_get_boundary("North Atlantic Ocean", "Ocean"), "sf" + ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_get_boundary(Limits = c("xmin" = 150, "xmax" = 170, "ymin" = -40, "ymax" = -20)), "sf") + splnr_get_boundary(Limits = c("xmin" = 150, "xmax" = 170, "ymin" = -40, "ymax" = -20)), "sf" + ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_get_boundary(Limits = "Global"), "sf") + splnr_get_boundary(Limits = "Global"), "sf" + ) }) diff --git a/tests/testthat/test-splnr_get_distCoast.R b/tests/testthat/test-splnr_get_distCoast.R index 6a68d4ab..a61b75b5 100644 --- a/tests/testthat/test-splnr_get_distCoast.R +++ b/tests/testthat/test-splnr_get_distCoast.R @@ -8,5 +8,3 @@ testthat::test_that("Correct function output", { expect_s3_class(result, "sf") }) - - diff --git a/tests/testthat/test-splnr_plot.R b/tests/testthat/test-splnr_plot.R index 41433cac..bae42a3d 100644 --- a/tests/testthat/test-splnr_plot.R +++ b/tests/testthat/test-splnr_plot.R @@ -14,10 +14,12 @@ landmass <- rnaturalearth::ne_countries( ) %>% sf::st_transform(cCRS) -PUs <- spatialgridr::get_grid(boundary = Bndry, - crs = cCRS, - output = "sf_hex", - resolution = PU_size) +PUs <- spatialgridr::get_grid( + boundary = Bndry, + crs = cCRS, + output = "sf_hex", + resolution = PU_size +) splnr_theme <- list( ggplot2::theme_bw(), @@ -37,55 +39,63 @@ distance <- splnr_get_distCoast(dat_PUs) # Binary plot of species distribution testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot(df = dat_species_bin, - colNames = "Spp1", - legendTitle = "Legend", - legendLabels = c("Absent", "Present")) - , "gg" + splnr_plot( + df = dat_species_bin, + colNames = "Spp1", + legendTitle = "Legend", + legendLabels = c("Absent", "Present") + ), + "gg" ) }) # Logical plot of species distribution testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot(df = dat_species_bin %>% dplyr::mutate(dplyr::across(tidyselect::starts_with("Spp"), as.logical)), - colNames = "Spp1", - legendTitle = "Legend", - legendLabels = c("Absent", "Present")) - , "gg" + splnr_plot( + df = dat_species_bin %>% dplyr::mutate(dplyr::across(tidyselect::starts_with("Spp"), as.logical)), + colNames = "Spp1", + legendTitle = "Legend", + legendLabels = c("Absent", "Present") + ), + "gg" ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot(df = distance, - colNames = "coastDistance_km", - plotTitle = "Distance to Coast", - legendTitle = "Distance (km)") - , "gg" + splnr_plot( + df = distance, + colNames = "coastDistance_km", + plotTitle = "Distance to Coast", + legendTitle = "Distance (km)" + ), + "gg" ) }) # Plot Planning Units testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot(df = dat_PUs) - , "gg" + splnr_plot(df = dat_PUs), + "gg" ) }) # Multi binary features testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot(df = dat_species_bin, - colNames = colnames(dat_species_bin %>% - sf::st_drop_geometry() %>% - dplyr::select( - tidyselect::starts_with("Spp"))), - legendTitle = "Number of features") - - , "gg" + splnr_plot( + df = dat_species_bin, + colNames = colnames(dat_species_bin %>% + sf::st_drop_geometry() %>% + dplyr::select( + tidyselect::starts_with("Spp") + )), + legendTitle = "Number of features" + ), + "gg" ) }) @@ -96,21 +106,20 @@ testthat::test_that("Correct function output", { splnr_gg_add( Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = splnr_theme - ) - , "gg" + ), + "gg" ) }) - testthat::test_that("Correct function output", { expect_s3_class( ggPU <- splnr_plot(df = PUs) + splnr_gg_add( Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = "Default" - ) - , "gg" + ), + "gg" ) }) @@ -123,12 +132,12 @@ testthat::test_that("Correct function output", { overlay2 = landmass, overlay3 = landmass, cropOverlay = PUs, ggtheme = "Default", - lockIn = dat_mpas, nameLockIn = "wdpa", + lockIn = dat_mpas, nameLockIn = "wdpa", typeLockIn = "Contours", alphaLockIn = 0.5, colorLockIn = "red", legendLockIn = "", labelLockIn = "MPAs" - ) - , "gg" + ), + "gg" ) }) @@ -164,11 +173,11 @@ dat_soln_for_lock_test <- dat_species_bin %>% testthat::test_that("splnr_gg_add() Full lock-in uses named labelLockIn vector for legend", { gg <- splnr_plot_solution(dat_soln_for_lock_test) + splnr_gg_add( - lockIn = dat_mpas, - nameLockIn = "wdpa", + lockIn = dat_mpas, + nameLockIn = "wdpa", labelLockIn = c(wdpa = "Marine Protected Areas"), legendLockIn = "Locked In", - ggtheme = FALSE + ggtheme = FALSE ) # The plot should build without error and be a gg object @@ -194,11 +203,11 @@ testthat::test_that("splnr_gg_add() Full lock-in uses named labelLockIn vector f testthat::test_that("splnr_gg_add() Full lock-in uses single string labelLockIn", { gg <- splnr_plot_solution(dat_soln_for_lock_test) + splnr_gg_add( - lockIn = dat_mpas, + lockIn = dat_mpas, nameLockIn = "wdpa", labelLockIn = "MPAs", legendLockIn = "Locked In", - ggtheme = FALSE + ggtheme = FALSE ) expect_s3_class(gg, "gg") }) @@ -208,10 +217,10 @@ testthat::test_that("splnr_gg_add() Full lock-in falls back to title-cased colum # Default labelLockIn = "MPAs" — single non-empty string, so it is used directly. gg <- splnr_plot_solution(dat_soln_for_lock_test) + splnr_gg_add( - lockIn = dat_mpas, + lockIn = dat_mpas, nameLockIn = "wdpa", legendLockIn = "Locked In", - ggtheme = FALSE + ggtheme = FALSE ) expect_s3_class(gg, "gg") }) @@ -221,11 +230,11 @@ testthat::test_that("splnr_gg_add() Full lock-out uses named labelLockOut vector # Reuse dat_mpas as a lock-out layer for testing purposes gg <- splnr_plot_solution(dat_soln_for_lock_test) + splnr_gg_add( - lockOut = dat_mpas, - nameLockOut = "wdpa", + lockOut = dat_mpas, + nameLockOut = "wdpa", labelLockOut = c(wdpa = "Shipping Lanes"), legendLockOut = "Locked Out", - ggtheme = FALSE + ggtheme = FALSE ) expect_s3_class(gg, "gg") }) @@ -264,8 +273,10 @@ testthat::test_that("splnr_gg_add() contours path produces a gg object", { contours_sf <- dat_mpas %>% dplyr::mutate(Category = dplyr::if_else(.data$wdpa == 1L, "MPA", "Other")) - gg <- splnr_plot(dat_species_bin, colNames = "Spp1", - legendTitle = "Spp1", legendLabels = c("Absent", "Present")) + + gg <- splnr_plot(dat_species_bin, + colNames = "Spp1", + legendTitle = "Spp1", legendLabels = c("Absent", "Present") + ) + splnr_gg_add( contours = contours_sf, ggtheme = FALSE @@ -295,8 +306,10 @@ testthat::test_that("splnr_gg_add() list ggtheme path appends theme elements", { ggplot2::theme(legend.position = "right") ) - gg <- splnr_plot(dat_species_bin, colNames = "Spp1", - legendTitle = "Spp1", legendLabels = c("Absent", "Present")) + + gg <- splnr_plot(dat_species_bin, + colNames = "Spp1", + legendTitle = "Spp1", legendLabels = c("Absent", "Present") + ) + splnr_gg_add(ggtheme = list_theme) expect_s3_class(gg, "gg") @@ -342,7 +355,7 @@ testthat::test_that("splnr_plot_costOverlay() errors when cost is not an sf obje testthat::test_that("splnr_plot_costOverlay() errors when cost sf lacks the costName column", { # Pass a valid sf object that does NOT contain the requested costName column. - cost_sf_no_col <- soln_local %>% dplyr::select("solution_1") # no "MyCost" column + cost_sf_no_col <- soln_local %>% dplyr::select("solution_1") # no "MyCost" column expect_error( splnr_plot_costOverlay( soln = soln_local, @@ -364,5 +377,3 @@ testthat::test_that("splnr_plot_costOverlay() works when a valid external cost s "gg" ) }) - - diff --git a/tests/testthat/test-splnr_plotting.R b/tests/testthat/test-splnr_plotting.R index 1afc0082..acc5c5f7 100644 --- a/tests/testthat/test-splnr_plotting.R +++ b/tests/testthat/test-splnr_plotting.R @@ -1,7 +1,7 @@ # 30 % target pDat1 <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), - cost_column = "Cost" + features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), + cost_column = "Cost" ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% @@ -13,8 +13,8 @@ soln1 <- pDat1 %>% # 50 % target soln2 <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), - cost_column = "Cost" + features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), + cost_column = "Cost" ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.5) %>% @@ -51,8 +51,9 @@ soln_zone <- prioritizr::problem( # Portfolio soln_portfolio <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), - cost_column = "Cost") %>% + features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), + cost_column = "Cost" +) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% prioritizr::add_binary_decisions() %>% @@ -61,76 +62,69 @@ soln_portfolio <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = r prioritizr::solve.ConservationProblem() - testthat::test_that("Correct function output", { expect_s3_class( splnr_plot_solution(soln1) + - splnr_gg_add(PUs = dat_PUs, ggtheme = "Default") - , "gg" + splnr_gg_add(PUs = dat_PUs, ggtheme = "Default"), + "gg" ) }) - - testthat::test_that("Correct function output", { expect_s3_class( splnr_plot_solution(soln_zone, - zones = TRUE, colorVals = c("#c6dbef", "#3182bd", "black"), - legendLabels = c("Not selected", "Zone 1", "Zone 2")) - , "gg" + zones = TRUE, colorVals = c("#c6dbef", "#3182bd", "black"), + legendLabels = c("Not selected", "Zone 1", "Zone 2") + ), + "gg" ) }) - - testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_costOverlay(soln = soln1) - , "gg" + splnr_plot_costOverlay(soln = soln1), + "gg" ) }) - testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_comparison(soln1, soln2) - , "gg" + splnr_plot_comparison(soln1, soln2), + "gg" ) }) - testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_selectionFreq(splnr_get_selFreq(solnMany = soln_portfolio, type = "portfolio")) - , "gg" + splnr_plot_selectionFreq(splnr_get_selFreq(solnMany = soln_portfolio, type = "portfolio")), + "gg" ) }) - testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_importanceScore(soln = soln1, pDat = pDat1, method = "Ferrier", decimals = 4) - , "gg" + splnr_plot_importanceScore(soln = soln1, pDat = pDat1, method = "Ferrier", decimals = 4), + "gg" ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_importanceScore(soln = soln1, pDat = pDat1, method = "RWR", decimals = 4) - , "gg" + splnr_plot_importanceScore(soln = soln1, pDat = pDat1, method = "RWR", decimals = 4), + "gg" ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_importanceScore(soln = soln1, pDat = pDat1, method = "RC", decimals = 4) - , "gg" + splnr_plot_importanceScore(soln = soln1, pDat = pDat1, method = "RC", decimals = 4), + "gg" ) }) @@ -139,10 +133,11 @@ testthat::test_that("Correct function output", { expect_s3_class( suppressWarnings( splnr_plot_corrMat(splnr_get_kappaCorrData(list(soln1, soln2), name_sol = c("soln1", "soln2")), - AxisLabels = c("Solution 1", "Solution 2")), + AxisLabels = c("Solution 1", "Solution 2") + ), classes = "lifecycle_warning_deprecated" - ) - , "gg" + ), + "gg" ) }) @@ -159,9 +154,9 @@ testthat::test_that("splnr_plot_solution() warns when colorVals length mismatche expect_warning( splnr_plot_solution( soln_zone, - zones = TRUE, + zones = TRUE, # Only 2 colours for 3 levels (0 = not selected, 1 = zone 1, 2 = zone 2) - colorVals = c("#c6dbef", "#3182bd"), + colorVals = c("#c6dbef", "#3182bd"), legendLabels = c("Not selected", "Zone 1", "Zone 2") ), "colorVals" @@ -180,5 +175,3 @@ testthat::test_that("splnr_plot_solution() warns when legendLabels length mismat "legendLabels" ) }) - - diff --git a/tests/testthat/test-splnr_plotting_climate.R b/tests/testthat/test-splnr_plotting_climate.R index b81e9985..94af49ad 100644 --- a/tests/testthat/test-splnr_plotting_climate.R +++ b/tests/testthat/test-splnr_plotting_climate.R @@ -1,4 +1,3 @@ - targets <- dat_species_bin %>% sf::st_drop_geometry() %>% colnames() %>% @@ -11,7 +10,8 @@ CPA <- splnr_climate_priorityAreaApproach( metric = dat_clim, targets = targets, direction = -1, - refugiaTarget = 1) + refugiaTarget = 1 +) out_sf <- CPA$Features %>% dplyr::mutate(Cost_None = 1, .row_id = dplyr::row_number()) %>% @@ -39,22 +39,23 @@ dat_solnClim <- prioritizr::solve.ConservationProblem(p1) testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_climData(df = dat_clim, colInterest = "metric") - , "gg") + splnr_plot_climData(df = dat_clim, colInterest = "metric"), + "gg" + ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_climKernelDensity(dat_solnClim, type = "Basic") - , "gg") + splnr_plot_climKernelDensity(dat_solnClim, type = "Basic"), + "gg" + ) }) testthat::test_that("Correct function output", { expect_s3_class( - splnr_plot_climKernelDensity(soln = dat_solnClim, type = "Normal") - , "gg") + splnr_plot_climKernelDensity(soln = dat_solnClim, type = "Normal"), + "gg" + ) }) - - diff --git a/tests/testthat/test-splnr_targets.R b/tests/testthat/test-splnr_targets.R index 319f5cdf..568c5f0c 100644 --- a/tests/testthat/test-splnr_targets.R +++ b/tests/testthat/test-splnr_targets.R @@ -1,4 +1,3 @@ - testthat::test_that("Correct function output", { expect_s3_class( dat_species_prob %>% diff --git a/tests/testthat/test-utils-climate.R b/tests/testthat/test-utils-climate.R index 8465505a..1775867f 100644 --- a/tests/testthat/test-utils-climate.R +++ b/tests/testthat/test-utils-climate.R @@ -1,4 +1,3 @@ - targets <- dat_species_bin %>% sf::st_drop_geometry() %>% colnames() %>% @@ -39,9 +38,9 @@ testthat::test_that("splnr_climate_priorityAreaApproach() returns correct struct expect_equal(nrow(result$Features), nrow(dat_species_bin)) # Features contains _CS and _NCS columns for every input feature - cs_cols <- paste0(feat_names, "_CS") + cs_cols <- paste0(feat_names, "_CS") ncs_cols <- paste0(feat_names, "_NCS") - expect_true(all(cs_cols %in% names(result$Features))) + expect_true(all(cs_cols %in% names(result$Features))) expect_true(all(ncs_cols %in% names(result$Features))) # Targets is a data.frame with feature and target columns @@ -63,9 +62,9 @@ testthat::test_that("splnr_climate_priorityAreaApproach() produces no NA targets result <- splnr_climate_priorityAreaApproach( features = dat_species_bin, metric = dat_clim, - targets = targets_tbl, # tibble, not plain data.frame + targets = targets_tbl, # tibble, not plain data.frame direction = -1, - percentile = 5 # small percentile → prop_cs > trgt for most features + percentile = 5 # small percentile → prop_cs > trgt for most features ) # The target column must be a plain numeric vector with no NA values. diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 86aee2ad..5164c7a5 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,32 +1,30 @@ testthat::test_that("Correct function output", { expect_s3_class(dat_species_prob %>% - splnr_replace_NAs("Spp2"), "sf") + splnr_replace_NAs("Spp2"), "sf") }) testthat::test_that("Correct function output", { expect_s3_class(dat_species_prob %>% - dplyr::mutate(Spp2 = dplyr::if_else(Spp2 < 0.01, NA, Spp2)) %>% - splnr_replace_NAs("Spp2"), "sf") + dplyr::mutate(Spp2 = dplyr::if_else(Spp2 < 0.01, NA, Spp2)) %>% + splnr_replace_NAs("Spp2"), "sf") }) - - testthat::test_that("Correct function output", { expect_s3_class(splnr_create_polygon(x = dplyr::tibble(x = seq(-50, 50, by = 1), y = 120) %>% - dplyr::bind_rows(dplyr::tibble(x = 50, y = seq(120, 180, by = 1))) %>% - dplyr::bind_rows(dplyr::tibble(x = seq(50, -50, by = -1), y = 180)) %>% - dplyr::bind_rows(dplyr::tibble(x = -50, y = seq(150, 120, by = -1)))), "sf" - ) + dplyr::bind_rows(dplyr::tibble(x = 50, y = seq(120, 180, by = 1))) %>% + dplyr::bind_rows(dplyr::tibble(x = seq(50, -50, by = -1), y = 180)) %>% + dplyr::bind_rows(dplyr::tibble(x = -50, y = seq(150, 120, by = -1)))), "sf") }) - testthat::test_that("Correct function output", { expect_s3_class( - splnr_match_names(dat_region, - c("Region1" = "SE Aust", "Region2" = "Tas", "Region3" = "NE Aust")), "sf" + splnr_match_names( + dat_region, + c("Region1" = "SE Aust", "Region2" = "Tas", "Region3" = "NE Aust") + ), "sf" ) }) @@ -73,12 +71,10 @@ testthat::test_that("Correct function output", { testthat::test_that("Correct function output", { expect_vector(dat_species_prob %>% - splnr_featureNames() - ) + splnr_featureNames()) }) - testthat::test_that("Correct function output", { expect_s3_class( dat_species_prob %>% @@ -88,10 +84,9 @@ testthat::test_that("Correct function output", { testthat::test_that("Correct function output", { - pDat1 <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), - cost_column = "Cost" + features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), + cost_column = "Cost" ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.3) %>% @@ -103,8 +98,8 @@ testthat::test_that("Correct function output", { prioritizr::solve.ConservationProblem() soln2 <- prioritizr::problem(dat_species_bin %>% dplyr::mutate(Cost = runif(n = dim(.)[[1]])), - features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), - cost_column = "Cost" + features = c("Spp1", "Spp2", "Spp3", "Spp4", "Spp5"), + cost_column = "Cost" ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(0.32) %>% diff --git a/vignettes/ClimateSmart.Rmd b/vignettes/ClimateSmart.Rmd index d18f0c78..41d4a971 100644 --- a/vignettes/ClimateSmart.Rmd +++ b/vignettes/ClimateSmart.Rmd @@ -9,13 +9,13 @@ vignette: > ```{r, include = FALSE} knitr::opts_chunk$set( -collapse = TRUE, -comment = "#>", -warning = FALSE, -cache = FALSE, -message = FALSE, -eval = TRUE, -fig.width = 9 + collapse = TRUE, + comment = "#>", + warning = FALSE, + cache = FALSE, + message = FALSE, + eval = TRUE, + fig.width = 9 ) ``` @@ -70,10 +70,12 @@ landmass <- rnaturalearth::ne_countries(scale = "medium", returnclass = "sf") %> ## Create Planning Units ```{r} -PUs <- spatialgridr::get_grid(boundary = Bndry, - crs = cCRS, - output = "sf_hex", - resolution = PU_size) +PUs <- spatialgridr::get_grid( + boundary = Bndry, + crs = cCRS, + output = "sf_hex", + resolution = PU_size +) ``` ## Get the features @@ -81,21 +83,21 @@ PUs <- spatialgridr::get_grid(boundary = Bndry, For our example, we will use a small subset of charismatic megafauna species of the Coral Sea to inform the conservation plan. We filtered the Aquamaps (Aquamaps.org) species distribution models for our study area for the following species: ```{r} Dict <- tibble::tribble( - ~nameCommon, ~nameVariable, ~category, - "Green sea turtle", "Chelonia_mydas", "Reptiles", - "Loggerhead sea turtle", "Caretta_caretta", "Reptiles", - "Hawksbill sea turtle", "Eretmochelys_imbricata", "Reptiles", - "Olive ridley sea turtle", "Lepidochelys_olivacea", "Reptiles", - "Saltwater crocodile", "Crocodylus_porosus", "Reptiles", - "Humpback whale", "Megaptera_novaeangliae", "Mammals", - "Common Minke whale", "Balaenoptera_acutorostrata", "Mammals", - "Dugong", "Dugong_dugon", "Mammals", - "Grey nurse shark", "Carcharias_taurus", "Sharks and rays", - "Tiger shark", "Galeocerdo_cuvier", "Sharks and rays", + ~nameCommon, ~nameVariable, ~category, + "Green sea turtle", "Chelonia_mydas", "Reptiles", + "Loggerhead sea turtle", "Caretta_caretta", "Reptiles", + "Hawksbill sea turtle", "Eretmochelys_imbricata", "Reptiles", + "Olive ridley sea turtle", "Lepidochelys_olivacea", "Reptiles", + "Saltwater crocodile", "Crocodylus_porosus", "Reptiles", + "Humpback whale", "Megaptera_novaeangliae", "Mammals", + "Common Minke whale", "Balaenoptera_acutorostrata", "Mammals", + "Dugong", "Dugong_dugon", "Mammals", + "Grey nurse shark", "Carcharias_taurus", "Sharks and rays", + "Tiger shark", "Galeocerdo_cuvier", "Sharks and rays", "Great hammerhead shark", "Sphyrna_mokarran", - "Sharks and rays", - "Giant oceanic manta ray", "Mobula_birostris", "Sharks and rays", - "Reef manta ray", "Mobula_alfredi", "Sharks and rays", + "Sharks and rays", + "Giant oceanic manta ray", "Mobula_birostris", "Sharks and rays", + "Reef manta ray", "Mobula_alfredi", "Sharks and rays", "Whitetip reef shark", "Triaenodon_obesus", "Sharks and rays", "Red-footed booby", "Sula_sula", "Birds" ) @@ -140,10 +142,10 @@ The climate velocity data can be visualized using the `splnr_plot_climData()` fu ```{r, fig.width = 9} (ggclim <- splnr_plot_climData(metric, "metric") + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` In our case, there were few areas with low climate velocity, which are the areas we define as climate refugia in our example. Usually, we would combine several metrics (e.g. exposure, velocity etc.) of multiple SSP scenarios to get more robust climate refugia. For our example, we randomly set areas with very high velocity to a value between `0.85-1` to visualize the output (CHANGE THIS LATER TO BETTER DATA). @@ -159,10 +161,10 @@ metric <- CoralSeaVelocity %>% ) (ggclim <- splnr_plot_climData(metric, "metric") + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` We then use the climate priority area approach `splnr_climate_priorityAreaApproach()` detailed in [Buenafe et al (2023)](https://doi.org/10.1002/eap.2852) to determine climate refugia. Briefly, this approach selects a percentile (in our case 5%) of the suitable habitat of each feature that is considered the most climate-smart. It also requires a `direction` input indicating at which side of the metric range the more climate-smart areas can be found. In our case, lower climate velocity denotes more climate-smart (`direction = -1`), but in other cases a higher value might represent the more climate-smart planning units (`direction = 1`). @@ -181,9 +183,9 @@ targets <- datEx_species_bin %>% CPA_Approach <- splnr_climate_priorityAreaApproach( features = datEx_species_bin, - metric = metric, - targets = targets, - direction = -1, + metric = metric, + targets = targets, + direction = -1, refugiaTarget = 1 ) @@ -193,7 +195,8 @@ out_sf <- CPA_Approach$Features %>% dplyr::select( tidyselect::starts_with("Cost_") ), - join = sf::st_equals) %>% + join = sf::st_equals + ) %>% sf::st_join(metric, join = sf::st_equals) targets <- CPA_Approach$Targets @@ -232,10 +235,10 @@ We can look at the resulting plan using `splnr_plot_solution()`. ```{r, fig.width = 9} (ggSoln <- splnr_plot_solution(dat_solnClim) + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` However, we are also interested how climate-smart the selected planning units in the solution actually are. For this, we can use a kernel density plot. @@ -243,7 +246,7 @@ However, we are also interested how climate-smart the selected planning units in ```{r, fig.width = 9} (ggClimDens <- splnr_plot_climKernelDensity( soln = list(dat_solnClim), - # names = c("Input 1"), + # names = c("Input 1"), type = "Normal", legendTitle = "Climate velocity (add unit)", xAxisLab = "Climate velocity" @@ -264,9 +267,9 @@ targets <- datEx_species_bin %>% Percentile_Approach <- splnr_climate_percentileApproach( features = datEx_species_bin, - metric = metric, - targets = targets, - direction = -1, + metric = metric, + targets = targets, + direction = -1, percentile = 35 ) @@ -304,7 +307,7 @@ p2 <- prioritizr::problem(out_sf, usedFeatures, "Cost_None") %>% prioritizr::add_default_solver(verbose = FALSE) dat_solnClimPercentile <- prioritizr::solve.ConservationProblem(p2, - force = TRUE + force = TRUE ) ``` @@ -312,10 +315,10 @@ We can look at the resulting plan using `splnr_plot_solution()`. ```{r, fig.width = 9} (ggSoln <- splnr_plot_solution(dat_solnClimPercentile) + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` However, we are also interested how climate-smart the selected planning units in the solution actually are. For this, we can use a kernel density plot @@ -324,7 +327,7 @@ However, we are also interested how climate-smart the selected planning units in ```{r, fig.width = 9} (ggClimDens <- splnr_plot_climKernelDensity( soln = list(dat_solnClimPercentile), - # names = c("Input 1"), + # names = c("Input 1"), type = "Normal", legendTitle = "Climate velocity (add unit)", xAxisLab = "Climate velocity" @@ -343,8 +346,8 @@ targets <- datEx_species_bin %>% Feature_Approach <- splnr_climate_featureApproach( features = datEx_species_bin, - metric = metric, - targets = targets, + metric = metric, + targets = targets, direction = 1 ) @@ -354,7 +357,8 @@ out_sf <- Feature_Approach$Features %>% dplyr::select( tidyselect::starts_with("Cost_") ), - join = sf::st_equals) %>% + join = sf::st_equals + ) %>% sf::st_join(metric, join = sf::st_equals) targets <- Feature_Approach$Targets @@ -385,10 +389,10 @@ dat_solnClimFeature <- prioritizr::solve.ConservationProblem(p3) ```{r, fig.width = 9} (ggSoln <- splnr_plot_solution(dat_solnClimFeature) + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` However, we are also interested how climate-smart the selected planning units in the solution actually are. For this, we can use a kernel density plot @@ -397,7 +401,7 @@ However, we are also interested how climate-smart the selected planning units in ```{r, fig.width = 9} (ggClimDens <- splnr_plot_climKernelDensity( soln = list(dat_solnClimFeature), - # names = c("Input 1"), + # names = c("Input 1"), type = "Normal", legendTitle = "Climate velocity (add unit)", xAxisLab = "Climate velocity" diff --git a/vignettes/GlobalFishingWatch.Rmd b/vignettes/GlobalFishingWatch.Rmd index 98fa2616..de9c2a7e 100644 --- a/vignettes/GlobalFishingWatch.Rmd +++ b/vignettes/GlobalFishingWatch.Rmd @@ -68,9 +68,11 @@ usethis::edit_r_environ() A region_id is necessary to use the `get_raster` function. ```{r, results='hide'} -region_id <- get_region_id(region = "Australia", - region_source = "EEZ", - key = gfwr::gfw_auth())$id[2] +region_id <- get_region_id( + region = "Australia", + region_source = "EEZ", + key = gfwr::gfw_auth() +)$id[2] ``` The `get_raster` function gets a raster of fishing effort from the API and @@ -103,12 +105,14 @@ Date range is limited to 1-year. Nevertheless, with some modifications, we can get round these problems through `splnr_get_gfw`. ```{r, message=FALSE} -data_sf_combined <- splnr_get_gfw(region = "Australia", - start_date = "2019-01-01", - end_date = "2023-12-31", - temp_res = "YEARLY", - spat_res = "LOW", - compress = FALSE) +data_sf_combined <- splnr_get_gfw( + region = "Australia", + start_date = "2019-01-01", + end_date = "2023-12-31", + temp_res = "YEARLY", + spat_res = "LOW", + compress = FALSE +) ``` @@ -119,8 +123,10 @@ and we constrain it to the boundaries of the given data.
- EEZ Polygons from `oceandatr` package ```{r, message = FALSE, results='hide'} # Check and modify if necessary the spatial reference of data_sf_combined -data_sf_combined <- sf::st_set_crs(data_sf_combined, - sf::st_crs(rnaturalearth::ne_coastline(scale = "large"))) +data_sf_combined <- sf::st_set_crs( + data_sf_combined, + sf::st_crs(rnaturalearth::ne_coastline(scale = "large")) +) coast_clipped <- rnaturalearth::ne_coastline(scale = "large") %>% sf::st_as_sf() %>% @@ -142,9 +148,11 @@ main_plot <- ggplot2::ggplot(data_sf_combined) + ggplot2::geom_sf(data = eezs, fill = NA, color = "red") + # Add the EEZ with hatching ggplot2::scale_color_viridis_c(guide = "legend") + ggplot2::theme_minimal() + - ggplot2::labs(title = "2022 Vessel Activity Map", - subtitle = "Fishing Hours recorded by GFW in Australia", - color = "Fishing Hours (log10)") + + ggplot2::labs( + title = "2022 Vessel Activity Map", + subtitle = "Fishing Hours recorded by GFW in Australia", + color = "Fishing Hours (log10)" + ) + ggplot2::theme( legend.position = "bottom", legend.text = ggplot2::element_text(size = 8), @@ -161,14 +169,16 @@ main_plot <- ggplot2::ggplot(data_sf_combined) + # The display and writing in this section is for information purposes only, to understand how the information on the grid is translated. overlay_plot <- ggplot2::ggplot(data_sf_combined) + - ggplot2::geom_rect(ggplot2::aes(xmin = -Inf,xmax = Inf,ymin = -Inf,ymax = Inf), fill = "white") + + ggplot2::geom_rect(ggplot2::aes(xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf), fill = "white") + ggplot2::geom_sf(ggplot2::aes(color = log10(ApparentFishingHrs))) + ggplot2::geom_sf(data = coast_clipped, color = "black", fill = NA) + # Add coastline ggplot2::geom_sf(data = eezs, fill = NA, color = "red") + ggplot2::scale_color_viridis_c(guide = "legend") + - ggplot2::labs(title = "Vessel Activity Map in Australia between 2019 and 2023", - subtitle = "Fishing Hours data recorded by GFW", - color = "Fishing Hours \n (log10)") + + ggplot2::labs( + title = "Vessel Activity Map in Australia between 2019 and 2023", + subtitle = "Fishing Hours data recorded by GFW", + color = "Fishing Hours \n (log10)" + ) + ggplot2::theme_minimal() + ggplot2::theme( legend.position = "none", @@ -217,11 +227,13 @@ must be seen in the context of this increase and not necessarily of more intense fishing activity. ```{r, message=FALSE} # We need to change the temporal range according to our need group by it to display the total fishing hours.
-data_sf_combined <- splnr_get_gfw(region = "Australia", - start_date = "2019-01-01", - end_date = "2023-12-31", - temp_res = "MONTHLY", - key = gfwr::gfw_auth()) %>% +data_sf_combined <- splnr_get_gfw( + region = "Australia", + start_date = "2019-01-01", + end_date = "2023-12-31", + temp_res = "MONTHLY", + key = gfwr::gfw_auth() +) %>% dplyr::group_by(Year, Month) %>% dplyr::summarize(Total_Fishing_Hours = sum(ApparentFishingHrs)) ``` @@ -241,10 +253,12 @@ ggplot2::ggplot(data_sf_combined, ggplot2::aes(x = Month, y = Total_Fishing_Hour Here we display the Vessel activity in 'Micronesia' in 2020 according to the fishing gear type. ```{r, message=FALSE} -data_sf_combined <- splnr_get_gfw(region = "Micronesia", - start_date = "2019-12-31", - end_date = "2021-01-01", - temp_res = "MONTHLY") +data_sf_combined <- splnr_get_gfw( + region = "Micronesia", + start_date = "2019-12-31", + end_date = "2021-01-01", + temp_res = "MONTHLY" +) ``` ```{r, echo=FALSE, message=FALSE, results='hide'} @@ -276,11 +290,13 @@ ggplot2::ggplot(data_sf_combined) + ### Flags Here we display the Vessel activity in Papua New Guinea according to Vessels flags. ```{r, echo=FALSE, message=FALSE, results='hide'} -data_sf_combined <- splnr_get_gfw(region = "Papua New Guinea", - start_date = "2019-12-31", - end_date = "2021-01-01", - temp_res = "YEARLY", - spat_res = "LOW") %>% +data_sf_combined <- splnr_get_gfw( + region = "Papua New Guinea", + start_date = "2019-12-31", + end_date = "2021-01-01", + temp_res = "YEARLY", + spat_res = "LOW" +) %>% sf::st_set_crs(sf::st_crs(rnaturalearth::ne_coastline(scale = "large"))) coast_clipped <- rnaturalearth::ne_coastline(scale = "large") %>% diff --git a/vignettes/MultipleUse.Rmd b/vignettes/MultipleUse.Rmd index 149692ff..a4ad5240 100644 --- a/vignettes/MultipleUse.Rmd +++ b/vignettes/MultipleUse.Rmd @@ -9,12 +9,12 @@ vignette: > ```{r, include = FALSE} knitr::opts_chunk$set( -collapse = TRUE, -comment = "#>", -warning = FALSE, -cache = FALSE, -message = FALSE, -eval = TRUE + collapse = TRUE, + comment = "#>", + warning = FALSE, + cache = FALSE, + message = FALSE, + eval = TRUE ) ``` @@ -62,11 +62,12 @@ landmass <- rnaturalearth::ne_countries( ## Create Planning Units ```{r} -PUs <- spatialgridr::get_grid(boundary = Bndry, - crs = cCRS, - output = "sf_hex", - resolution = PU_size) - +PUs <- spatialgridr::get_grid( + boundary = Bndry, + crs = cCRS, + output = "sf_hex", + resolution = PU_size +) ``` We can also use a customised `ggplot` theme that can be passed as a list to `splnr_gg_add()` and that can then be used for all plots. For example: @@ -90,22 +91,22 @@ splnr_theme <- list( For our example, we will use a small subset of charismatic megafauna species of the Coral Sea to inform the conservation plan. We filtered the Aquamaps (Aquamaps.org) species distribution models for our study area for the following species: ```{r} Dict <- tibble::tribble( - ~nameCommon, ~nameVariable, ~category, - "Green sea turtle", "Chelonia_mydas", "Reptiles", - "Loggerhead sea turtle", "Caretta_caretta", "Reptiles", - "Hawksbill sea turtle", "Eretmochelys_imbricata", "Reptiles", - "Olive ridley sea turtle", "Lepidochelys_olivacea", "Reptiles", - "Saltwater crocodile", "Crocodylus_porosus", "Reptiles", - "Humpback whale", "Megaptera_novaeangliae", "Mammals", + ~nameCommon, ~nameVariable, ~category, + "Green sea turtle", "Chelonia_mydas", "Reptiles", + "Loggerhead sea turtle", "Caretta_caretta", "Reptiles", + "Hawksbill sea turtle", "Eretmochelys_imbricata", "Reptiles", + "Olive ridley sea turtle", "Lepidochelys_olivacea", "Reptiles", + "Saltwater crocodile", "Crocodylus_porosus", "Reptiles", + "Humpback whale", "Megaptera_novaeangliae", "Mammals", "Common Minke whale", "Balaenoptera_acutorostrata", - "Mammals", - "Dugong", "Dugong_dugon", "Mammals", - "Grey nurse shark", "Carcharias_taurus", "Sharks and rays", - "Tiger shark", "Galeocerdo_cuvier", "Sharks and rays", + "Mammals", + "Dugong", "Dugong_dugon", "Mammals", + "Grey nurse shark", "Carcharias_taurus", "Sharks and rays", + "Tiger shark", "Galeocerdo_cuvier", "Sharks and rays", "Great hammerhead shark", "Sphyrna_mokarran", - "Sharks and rays", - "Giant oceanic manta ray", "Mobula_birostris", "Sharks and rays", - "Reef manta ray", "Mobula_alfredi", "Sharks and rays", + "Sharks and rays", + "Giant oceanic manta ray", "Mobula_birostris", "Sharks and rays", + "Reef manta ray", "Mobula_alfredi", "Sharks and rays", "Whitetip reef shark", "Triaenodon_obesus", "Sharks and rays", "Red-footed booby", "Sula_sula", "Birds" ) @@ -151,8 +152,7 @@ s1 <- p1 %>% prioritizr::solve.ConservationProblem() (ggSoln <- splnr_plot_solution(s1) + - splnr_gg_add(PUs = PUs, Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = splnr_theme)) - + splnr_gg_add(PUs = PUs, Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = splnr_theme)) ``` We can also have a look at how well the set target was met. @@ -370,10 +370,10 @@ s4 <- p4 %>% colorVals = c("#c6dbef", "#3182bd", "black"), legendLabels = c("Not selected", "Zone 1", "Zone 2") ) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` #### Across zones @@ -409,10 +409,10 @@ s5 <- p5 %>% colorVals = c("#c6dbef", "#3182bd", "black"), legendLabels = c("Not selected", "Zone 1", "Zone 2") ) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` ### Adding constraints @@ -425,7 +425,7 @@ When using zones with constraints, we use the `prioritizr` function `add_manual_ mpas <- MPAsCoralSea %>% dplyr::mutate(zone = "zone 1") %>% dplyr::rename(status = wdpa) %>% - tibble::rowid_to_column("pu") %>% + tibble::rowid_to_column("pu") %>% sf::st_drop_geometry() %>% tibble::tibble() %>% dplyr::filter(status == 1) @@ -504,10 +504,10 @@ s7 <- p7 %>% colorVals = c("#c6dbef", "#3182bd", "black"), legendLabels = c("Not selected", "Zone 1", "Zone 2") ) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` ### Alternative: linear constraints @@ -539,7 +539,7 @@ p8 <- prioritizr::problem( prioritizr::add_min_set_objective() %>% prioritizr::add_relative_targets(target8) %>% prioritizr::add_linear_constraints(sum(costRandom$CostR) * 0.1, - sense = "<=", costRandom$CostR + sense = "<=", costRandom$CostR ) %>% prioritizr::add_binary_decisions() %>% prioritizr::add_default_solver(verbose = FALSE) @@ -554,7 +554,7 @@ We can visualise the solution again: ```{r, fig.width = 9} (gg_s8 <- splnr_plot_solution(s8) + - splnr_gg_add(PUs = PUs, Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = splnr_theme)) + splnr_gg_add(PUs = PUs, Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = splnr_theme)) ``` @@ -613,8 +613,8 @@ We can see here that we defined to (random) cost layers with the cost layer for ```{r} p10 <- prioritizr::problem(out_sf, - z10, - cost_column = c("Cost1", "Cost2") + z10, + cost_column = c("Cost1", "Cost2") ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_manual_targets(targetAcross) %>% @@ -641,9 +641,9 @@ The overall summary shows that every feature's suitable habitat was represented ```{r, fig.width=9} (gg_s10 <- splnr_plot_solution(s10, - zones = TRUE, - colorVals = c("#c6dbef", "#3182bd", "black"), - legendLabels = c("Not selected", "Zone 1", "Zone 2") + zones = TRUE, + colorVals = c("#c6dbef", "#3182bd", "black"), + legendLabels = c("Not selected", "Zone 1", "Zone 2") ) + splnr_gg_add( PUs = PUs, Bndry = Bndry, overlay = landmass, @@ -673,12 +673,12 @@ We then define the conservation problem and add a linear constraint for 30% of t ```{r} p11 <- prioritizr::problem(out_sf, - z10, - cost_column = c("Cost1", "Cost2") + z10, + cost_column = c("Cost1", "Cost2") ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_linear_constraints(sum(CostArea[, 1]) * 0.3, - sense = "<=", CostArea + sense = "<=", CostArea ) %>% prioritizr::add_manual_targets(targetAcross) %>% prioritizr::add_binary_decisions() %>% @@ -791,8 +791,8 @@ out_sf <- datSpecZone1 %>% ```{r} p12 <- prioritizr::problem(out_sf, - z12, - cost_column = c("Cost1", "Cost2", "Cost3") + z12, + cost_column = c("Cost1", "Cost2", "Cost3") ) %>% prioritizr::add_min_set_objective() %>% prioritizr::add_manual_targets(targetAcrossSome) %>% diff --git a/vignettes/spatialplanr.Rmd b/vignettes/spatialplanr.Rmd index 8323325e..f29e76b3 100644 --- a/vignettes/spatialplanr.Rmd +++ b/vignettes/spatialplanr.Rmd @@ -9,13 +9,13 @@ vignette: > ```{r, include = FALSE} knitr::opts_chunk$set( -collapse = TRUE, -comment = "#>", -warning = FALSE, -cache = FALSE, -message = FALSE, -eval = TRUE, -fig.width = 9 + collapse = TRUE, + comment = "#>", + warning = FALSE, + cache = FALSE, + message = FALSE, + eval = TRUE, + fig.width = 9 ) ``` @@ -84,18 +84,19 @@ landmass <- rnaturalearth::ne_countries( ## Create Planning Units ```{r} -PUs <- spatialgridr::get_grid(boundary = Bndry, - crs = cCRS, - output = "sf_hex", - resolution = PU_size) - +PUs <- spatialgridr::get_grid( + boundary = Bndry, + crs = cCRS, + output = "sf_hex", + resolution = PU_size +) ``` We can check what the PUs look like ```{r} (ggPU <- splnr_plot(df = PUs) + - ggplot2::theme_bw()) # Plot Planning Units + ggplot2::theme_bw()) # Plot Planning Units ``` If we want to add additional properties to our map, for example landmass @@ -103,10 +104,10 @@ or the boundary, we can use `splnr_gg_add()`. ```{r} (ggPU <- splnr_plot(df = PUs) + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = "Default" - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = "Default" + )) ``` We can also use a customised `ggplpot` theme that can be passed as a @@ -127,10 +128,10 @@ splnr_theme <- list( ) (ggPU <- splnr_plot(PUs) + - splnr_gg_add( - Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` ## Get the features @@ -142,20 +143,20 @@ area for the following species: ```{r} Dict <- tibble::tribble( - ~nameCommon, ~nameVariable, ~category, - "Green sea turtle", "Chelonia_mydas", "Reptiles", - "Loggerhead sea turtle", "Caretta_caretta", "Reptiles", - "Hawksbill sea turtle", "Eretmochelys_imbricata", "Reptiles", - "Olive ridley sea turtle", "Lepidochelys_olivacea", "Reptiles", - "Saltwater crocodile", "Crocodylus_porosus", "Reptiles", - "Humpback whale", "Megaptera_novaeangliae", "Mammals", - "Common Minke whale", "Balaenoptera_acutorostrata", "Mammals", - "Dugong", "Dugong_dugon", "Mammals", - "Grey nurse shark", "Carcharias_taurus", "Sharks and rays", - "Tiger shark", "Galeocerdo_cuvier", "Sharks and rays", - "Great hammerhead shark", "Sphyrna_mokarran", "Sharks and rays", - "Giant oceanic manta ray", "Mobula_birostris", "Sharks and rays", - "Reef manta ray", "Mobula_alfredi", "Sharks and rays", + ~nameCommon, ~nameVariable, ~category, + "Green sea turtle", "Chelonia_mydas", "Reptiles", + "Loggerhead sea turtle", "Caretta_caretta", "Reptiles", + "Hawksbill sea turtle", "Eretmochelys_imbricata", "Reptiles", + "Olive ridley sea turtle", "Lepidochelys_olivacea", "Reptiles", + "Saltwater crocodile", "Crocodylus_porosus", "Reptiles", + "Humpback whale", "Megaptera_novaeangliae", "Mammals", + "Common Minke whale", "Balaenoptera_acutorostrata", "Mammals", + "Dugong", "Dugong_dugon", "Mammals", + "Grey nurse shark", "Carcharias_taurus", "Sharks and rays", + "Tiger shark", "Galeocerdo_cuvier", "Sharks and rays", + "Great hammerhead shark", "Sphyrna_mokarran", "Sharks and rays", + "Giant oceanic manta ray", "Mobula_birostris", "Sharks and rays", + "Reef manta ray", "Mobula_alfredi", "Sharks and rays", "Whitetip reef shark", "Triaenodon_obesus", "Sharks and rays", "Red-footed booby", "Sula_sula", "Birds" ) @@ -223,15 +224,17 @@ we can also plot the number of features with suitable habitat within a Planning Unit of the study region. ```{r} -(ggFeatNo <- splnr_plot(df = datEx_species_bin, - colNames = colnames(datEx_species_bin %>% - sf::st_drop_geometry()), - plotTitle = "", - legendTitle = "Number of features") + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) +(ggFeatNo <- splnr_plot( + df = datEx_species_bin, + colNames = colnames(datEx_species_bin %>% + sf::st_drop_geometry()), + plotTitle = "", + legendTitle = "Number of features" +) + + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` ## Prepare Data for prioritization @@ -260,12 +263,14 @@ units are assigned an equal cost of 1. ```{r} out_sf$Cost_None <- 1 -(ggCost <- splnr_plot(out_sf, colNames = "Cost_None", - legendTitle = "Cost", legendLabels = "1") + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) +(ggCost <- splnr_plot(out_sf, + colNames = "Cost_None", + legendTitle = "Cost", legendLabels = "1" +) + + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` @@ -276,24 +281,26 @@ The gfwr package allows us to recover data from fisheries across the world, we set here the parameter `compress` as `TRUE` to recover the `Apparent fishing hours` per coordinates. ```{r, eval=FALSE} -gfw_data <- splnr_get_gfw(region = 'Australia', - start_date = "2022-01-01", - end_date = "2022-12-31", - temp_res = "yearly", - cCRS = cCRS, - compress = TRUE) %>% +gfw_data <- splnr_get_gfw( + region = "Australia", + start_date = "2022-01-01", + end_date = "2022-12-31", + temp_res = "yearly", + cCRS = cCRS, + compress = TRUE +) %>% sf::st_interpolate_aw(PUs, extensive = TRUE) out_sf$Apparent.Fishing.Hours <- 0 # Add column to PUs -out_sf$Apparent.Fishing.Hours[as.numeric(rownames(PUs))] <- +out_sf$Apparent.Fishing.Hours[as.numeric(rownames(PUs))] <- gfw_data$Apparent.Fishing.Hours # Put corresponding data in PUs (ggCost <- splnr_plot(out_sf, colNames = "Apparent.Fishing.Hours") + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` ###### Other features @@ -302,25 +309,31 @@ Many features can be taken into account as cost layers before the prioritization, we provide here different features from the `oceandatr`package. ```{r, eval=FALSE, echo=FALSE} -bathymetry <- oceandatr::get_bathymetry(planning_grid = PUs, - keep = FALSE, - classify_bathymetry = FALSE) +bathymetry <- oceandatr::get_bathymetry( + planning_grid = PUs, + keep = FALSE, + classify_bathymetry = FALSE +) geomorphology <- oceandatr::get_geomorphology(planning_grid = PUs) knolls <- oceandatr::get_knolls(planning_grid = PUs) -seamounts <- oceandatr::get_seamounts_buffered(planning_grid = PUs, - buffer = 30000) +seamounts <- oceandatr::get_seamounts_buffered( + planning_grid = PUs, + buffer = 30000 +) coral_habitat <- oceandatr::get_coral_habitat(planning_grid = PUs) -enviro_regions <- oceandatr::get_enviro_regions(planning_grid = PUs, - max_num_clusters = 5) +enviro_regions <- oceandatr::get_enviro_regions( + planning_grid = PUs, + max_num_clusters = 5 +) ``` ```{r, eval=FALSE, echo=FALSE} -splnr_plot(df = bathymetry, colNames = "bathymetry", plotTitle = "") + +splnr_plot(df = bathymetry, colNames = "bathymetry", plotTitle = "") + splnr_gg_add( PUs = PUs, Bndry = Bndry, overlay = landmass, cropOverlay = PUs, ggtheme = splnr_theme - ) + ) ``` @@ -369,14 +382,15 @@ importance scores ### Visualization of the solution ```{r} -(ggSoln <- splnr_plot(datEx_soln, - colNames = "solution_1", - legendTitle = "Solution", - legendLabels = c("0","1")) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) +(ggSoln <- splnr_plot(datEx_soln, + colNames = "solution_1", + legendTitle = "Solution", + legendLabels = c("0", "1") +) + + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` This plot shows the optimal solution for the planning region that meets @@ -410,17 +424,17 @@ region. ```{r, fig.height=7} dfTarget <- splnr_get_featureRep(datEx_soln, datEx_problem, - climsmart = FALSE, - solnCol = "solution_1" + climsmart = FALSE, + solnCol = "solution_1" ) -(ggTarget <- splnr_plot_featureRep(dfTarget, - category = Dict, - renameFeatures = TRUE, - namesToReplace = Dict, - categoryFeatureCol = "nameCommon", - nr = 1, showTarget = TRUE, +(ggTarget <- splnr_plot_featureRep(dfTarget, + category = Dict, + renameFeatures = TRUE, + namesToReplace = Dict, + categoryFeatureCol = "nameCommon", + nr = 1, showTarget = TRUE, )) ``` @@ -429,8 +443,8 @@ to be done. ```{r, eval=FALSE} dfTargetCirc <- dfTarget %>% -dplyr::select("feature", "value", "group") %>% -na.omit() + dplyr::select("feature", "value", "group") %>% + na.omit() colors <- c( "important" = "darkgreen", @@ -505,10 +519,10 @@ LockedIn <- splnr_get_MPAs(PUs, "Australia") %>% ```{r} (ggMPA <- splnr_plot(MPAsCoralSea, "wdpa") + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` We will also include targets based on IUCN categories to prioritise @@ -526,7 +540,6 @@ target, so species with a greater area of suitable habitat are assigned a lower target. ```{r} - minTarget <- 0.1 maxTarget <- 0.2 @@ -543,7 +556,6 @@ an increased target of 0.3 for all species with an increased thread level on the IUCN Red List("EX", "EW", "CR", "EN", "VU"). ```{r, eval = FALSE} - IUCN_IA_Targets <- IA_Targets %>% splnr_get_IUCNRedList(species_col = "Species") %>% # Add RL data to the df splnr_targets_byIUCN(IUCN_target = 0.3) @@ -569,10 +581,10 @@ datEx_soln2 <- datEx_problem2 %>% prioritizr::solve.ConservationProblem() (ggSoln2 <- splnr_plot_solution(datEx_soln2) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` But we locked-in areas that were already existing Marine Protected Areas (MPAs). If we want to @@ -581,12 +593,12 @@ MPAs, we can add this to the `splnr_gg_add()` function. ```{r} (splnr_plot_solution(datEx_soln2) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, lockIn = MPAsCoralSea, - nameLockIn = "wdpa", typeLockIn = "Full", - colorLockIn = "lightgrey", alphaLockIn = 0.2, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, lockIn = MPAsCoralSea, + nameLockIn = "wdpa", typeLockIn = "Full", + colorLockIn = "lightgrey", alphaLockIn = 0.2, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` If we instead only want to see the contours of the locked-in areas we @@ -594,22 +606,22 @@ can set `typeLockIn = "Contours"` in `splnr_gg_add()`. ```{r} (splnr_plot_solution(datEx_soln2) + - splnr_gg_add( - lockIn = MPAsCoralSea, - nameLockIn = "wdpa", typeLockIn = "Contours", - colorLockIn = "lightgrey", alphaLockIn = 0.2, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + lockIn = MPAsCoralSea, + nameLockIn = "wdpa", typeLockIn = "Contours", + colorLockIn = "lightgrey", alphaLockIn = 0.2, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` ### Visualize comparison ```{r} (ggComp <- splnr_plot_comparison(datEx_soln, datEx_soln2) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ``` This plot shows how the first solution (without current MPAs) differs @@ -620,11 +632,11 @@ selected in both solutions (grey). ```{r} CorrMat <- splnr_get_kappaCorrData(list(datEx_soln, datEx_soln2), - name_sol = c("soln1", "soln2") + name_sol = c("soln1", "soln2") ) (ggCorr <- splnr_plot_corrMat(CorrMat, - AxisLabels = c("Solution 1", "Solution 2") + AxisLabels = c("Solution 1", "Solution 2") )) ``` @@ -653,8 +665,8 @@ selFreq <- datEx_soln_portfolio %>% # calculate selection frequency dplyr::select(selFreq) (ggselFreq <- splnr_plot_selectionFreq(selFreq) + - splnr_gg_add( - PUs = PUs, Bndry = Bndry, overlay = landmass, - cropOverlay = PUs, ggtheme = splnr_theme - )) + splnr_gg_add( + PUs = PUs, Bndry = Bndry, overlay = landmass, + cropOverlay = PUs, ggtheme = splnr_theme + )) ```