From 97a61c6167282c4feb91ec6e2acd6ae00ba72441 Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Sun, 12 Jan 2025 11:31:09 +1300 Subject: [PATCH 1/4] feat: curvatures --- NAMESPACE | 2 + R/curvature.R | 178 ++++++++++++++++++++++++++++++++ man/wbw_gaussian_curvature.Rd | 71 +++++++++++++ man/wbw_maximal_curvature.Rd | 72 +++++++++++++ tests/tinytest/test_curvature.R | 43 ++++++++ tests/tinytest/test_filter.R | 48 ++++++--- 6 files changed, 398 insertions(+), 16 deletions(-) create mode 100644 R/curvature.R create mode 100644 man/wbw_gaussian_curvature.Rd create mode 100644 man/wbw_maximal_curvature.Rd create mode 100644 tests/tinytest/test_curvature.R diff --git a/NAMESPACE b/NAMESPACE index ca8b103..d432d67 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,6 +31,7 @@ export(wbw_data_type) export(wbw_download_sample_data) export(wbw_ext) export(wbw_fill_missing_data) +export(wbw_gaussian_curvature) export(wbw_gaussian_filter) export(wbw_high_pass_filter) export(wbw_high_pass_median_filter) @@ -41,6 +42,7 @@ export(wbw_is_int) export(wbw_is_rgb) export(wbw_majority_filter) export(wbw_max_procs) +export(wbw_maximal_curvature) export(wbw_maximum_filter) export(wbw_mean_filter) export(wbw_median_filter) diff --git a/R/curvature.R b/R/curvature.R new file mode 100644 index 0000000..20d3f9c --- /dev/null +++ b/R/curvature.R @@ -0,0 +1,178 @@ +#' Gaussian Curvature +#' @keywords geomorphometry +#' +#' @description +#' This tool calculates the Gaussian curvature from a digital elevation +#' model (\eqn{dem}). Gaussian curvature is the product of maximal and +#' minimal curvatures, and retains values in each point of the topographic +#' surface after its bending without breaking, stretching, and +#' compressing (Florinsky, 2017). +#' +#' Gaussian curvature is measured in units of \eqn{m^{-2}}. +#' +#' @details +#' Curvature values are often very small and as such the user may opt to +#' log-transform the output raster (\eqn{log_transform}). Transforming +#' the values applies the equation by Shary et al. (2002): +#' +#' \deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} +#' +#' where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +#' grid cell size. +#' +#' For DEMs in projected coordinate systems, the tool uses the +#' 3rd-order bivariate Taylor polynomial method described by +#' Florinsky (2016). Based on a polynomial fit of the elevations +#' within the 5x5 neighbourhood surrounding each cell, this method +#' is considered more robust against outlier elevations (noise) +#' than other methods. +#' +#' For DEMs in geographic coordinate systems (i.e. angular units), the +#' tool uses the 3x3 polynomial fitting method for equal angle grids also +#' described by Florinsky (2016). +#' +#' @eval rd_input_raster("dem") +#' @param log_transform \code{logical}, default \code{FALSE}. Wheter +#' log-transform the output raster or not. See details. +#' @param z_factor \code{double}, Z conversion factor is only important +#' when the vertical and horizontal units are not the same in the DEM. +#' When this is the case, the algorithm will multiply each elevation in the +#' DEM by the Z conversion factor +#' +#' @return [WhiteboxRaster] object in units of \eqn{m^{-2}}. +#' +#' @eval rd_wbw_link("gaussian_curvature") +#' @references +#' Florinsky, I. (2016). Digital terrain analysis in soil science and +#' geology. Academic Press.
+#' Florinsky, I. V. (2017). An illustrated introduction to general +#' geomorphometry. Progress in Physical Geography, 41(6), 723-752.
+#' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +#' quantitative methods of land surface analysis. Geoderma 107: 1–32.
+#' +#' @seealso [wbw_maximal_curvature()] +#' +#' @eval rd_example("wbw_gaussian_curvature") +#' +#' @export +wbw_gaussian_curvature <- S7::new_generic( + name = "wbw_gaussian_curvature", + dispatch_args = "dem", + fun = function(dem, log_transform = FALSE, z_factor = 1) { + S7::S7_dispatch() + } +) + +S7::method(wbw_gaussian_curvature, WhiteboxRaster) <- function( + dem, + log_transform = FALSE, + z_factor = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_logical(log_transform, len = 1) + checkmate::assert_double(z_factor, len = 1) + + # WBT + out <- wbe$gaussian_curvature( + dem = dem@source, + log_transform = log_transform, + z_factor = z_factor + ) + + # Return + WhiteboxRaster( + name = "Gaussian Curvature", + source = out + ) +} + +#' Maximal Curvature +#' @keywords geomorphometry +#' +#' @description +#' This tool calculates the maximal curvature from a digital elevation model +#' (\eqn{dem}). Maximal curvature is the curvature of a principal section +#' with the highest value of curvature at a given point of the topographic +#' surface (Florinsky, 2017). The values of this curvature are unbounded, +#' and positive values correspond to ridge positions while negative values +#' are indicative of closed depressions (Florinsky, 2016). +#' +#' Gaussian curvature is measured in units of \eqn{m^{-1}}. +#' +#' @details +#' Curvature values are often very small and as such the user may opt to +#' log-transform the output raster (\eqn{log_transform}). Transforming +#' the values applies the equation by Shary et al. (2002): +#' +#' \deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} +#' +#' where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +#' grid cell size. +#' +#' For DEMs in projected coordinate systems, the tool uses the +#' 3rd-order bivariate Taylor polynomial method described by +#' Florinsky (2016). Based on a polynomial fit of the elevations +#' within the 5x5 neighbourhood surrounding each cell, this method +#' is considered more robust against outlier elevations (noise) +#' than other methods. +#' +#' For DEMs in geographic coordinate systems (i.e. angular units), the +#' tool uses the 3x3 polynomial fitting method for equal angle grids also +#' described by Florinsky (2016). +#' +#' @eval rd_input_raster("dem") +#' @param log_transform \code{logical}, default \code{FALSE}. Wheter +#' log-transform the output raster or not. See details. +#' @param z_factor \code{double}, Z conversion factor is only important +#' when the vertical and horizontal units are not the same in the DEM. +#' When this is the case, the algorithm will multiply each elevation in the +#' DEM by the Z conversion factor +#' +#' @return [WhiteboxRaster] object in units of \eqn{m^{-1}}. +#' +#' @eval rd_wbw_link("maximal_curvature") +#' @references +#' Florinsky, I. (2016). Digital terrain analysis in soil science and +#' geology. Academic Press.
+#' Florinsky, I. V. (2017). An illustrated introduction to general +#' geomorphometry. Progress in Physical Geography, 41(6), 723-752.
+#' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +#' quantitative methods of land surface analysis. Geoderma 107: 1–32.
+#' +#' @seealso [wbw_gaussian_curvature()] +#' +#' @eval rd_example("wbw_maximal_curvature") +#' +#' @export +wbw_maximal_curvature <- S7::new_generic( + name = "wbw_maximal_curvature", + dispatch_args = "dem", + fun = function(dem, log_transform = FALSE, z_factor = 1) { + S7::S7_dispatch() + } +) + +S7::method(wbw_maximal_curvature, WhiteboxRaster) <- function( + dem, + log_transform = FALSE, + z_factor = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_logical(log_transform, len = 1) + checkmate::assert_double(z_factor, len = 1) + + # WBT + out <- wbe$maximal_curvature( + dem = dem@source, + log_transform = log_transform, + z_factor = z_factor + ) + + # Return + WhiteboxRaster( + name = "Maximal Curvature", + source = out + ) +} diff --git a/man/wbw_gaussian_curvature.Rd b/man/wbw_gaussian_curvature.Rd new file mode 100644 index 0000000..2d85676 --- /dev/null +++ b/man/wbw_gaussian_curvature.Rd @@ -0,0 +1,71 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/curvature.R +\name{wbw_gaussian_curvature} +\alias{wbw_gaussian_curvature} +\title{Gaussian Curvature} +\usage{ +wbw_gaussian_curvature(dem, log_transform = FALSE, z_factor = 1) +} +\arguments{ +\item{dem}{Raster object of class \link{WhiteboxRaster}. See \code{\link[=wbw_read_raster]{wbw_read_raster()}} for more details.} + +\item{log_transform}{\code{logical}, default \code{FALSE}. Wheter +log-transform the output raster or not. See details.} + +\item{z_factor}{\code{double}, Z conversion factor is only important +when the vertical and horizontal units are not the same in the DEM. +When this is the case, the algorithm will multiply each elevation in the +DEM by the Z conversion factor} +} +\value{ +\link{WhiteboxRaster} object in units of \eqn{m^{-2}}. +} +\description{ +This tool calculates the Gaussian curvature from a digital elevation +model (\eqn{dem}). Gaussian curvature is the product of maximal and +minimal curvatures, and retains values in each point of the topographic +surface after its bending without breaking, stretching, and +compressing (Florinsky, 2017). + +Gaussian curvature is measured in units of \eqn{m^{-2}}. +} +\details{ +Curvature values are often very small and as such the user may opt to +log-transform the output raster (\eqn{log_transform}). Transforming +the values applies the equation by Shary et al. (2002): + +\deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} + +where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +grid cell size. + +For DEMs in projected coordinate systems, the tool uses the +3rd-order bivariate Taylor polynomial method described by +Florinsky (2016). Based on a polynomial fit of the elevations +within the 5x5 neighbourhood surrounding each cell, this method +is considered more robust against outlier elevations (noise) +than other methods. + +For DEMs in geographic coordinate systems (i.e. angular units), the +tool uses the 3x3 polynomial fitting method for equal angle grids also +described by Florinsky (2016). +} +\examples{ +f <- system.file("extdata/dem.tif", package = "wbw") +wbw_read_raster(f) |> + wbw_gaussian_curvature() +} +\references{ +For more information, see \url{https://www.whiteboxgeo.com/manual/wbw-user-manual/book/tool_help.html#gaussian_curvature} + +Florinsky, I. (2016). Digital terrain analysis in soil science and +geology. Academic Press. \if{html}{\out{
}} +Florinsky, I. V. (2017). An illustrated introduction to general +geomorphometry. Progress in Physical Geography, 41(6), 723-752. \if{html}{\out{
}} +Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} +} +\seealso{ +\code{\link[=wbw_maximal_curvature]{wbw_maximal_curvature()}} +} +\keyword{geomorphometry} diff --git a/man/wbw_maximal_curvature.Rd b/man/wbw_maximal_curvature.Rd new file mode 100644 index 0000000..6039f64 --- /dev/null +++ b/man/wbw_maximal_curvature.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/curvature.R +\name{wbw_maximal_curvature} +\alias{wbw_maximal_curvature} +\title{Maximal Curvature} +\usage{ +wbw_maximal_curvature(dem, log_transform = FALSE, z_factor = 1) +} +\arguments{ +\item{dem}{Raster object of class \link{WhiteboxRaster}. See \code{\link[=wbw_read_raster]{wbw_read_raster()}} for more details.} + +\item{log_transform}{\code{logical}, default \code{FALSE}. Wheter +log-transform the output raster or not. See details.} + +\item{z_factor}{\code{double}, Z conversion factor is only important +when the vertical and horizontal units are not the same in the DEM. +When this is the case, the algorithm will multiply each elevation in the +DEM by the Z conversion factor} +} +\value{ +\link{WhiteboxRaster} object in units of \eqn{m^{-1}}. +} +\description{ +This tool calculates the maximal curvature from a digital elevation model +(\eqn{dem}). Maximal curvature is the curvature of a principal section +with the highest value of curvature at a given point of the topographic +surface (Florinsky, 2017). The values of this curvature are unbounded, +and positive values correspond to ridge positions while negative values +are indicative of closed depressions (Florinsky, 2016). + +Gaussian curvature is measured in units of \eqn{m^{-1}}. +} +\details{ +Curvature values are often very small and as such the user may opt to +log-transform the output raster (\eqn{log_transform}). Transforming +the values applies the equation by Shary et al. (2002): + +\deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} + +where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +grid cell size. + +For DEMs in projected coordinate systems, the tool uses the +3rd-order bivariate Taylor polynomial method described by +Florinsky (2016). Based on a polynomial fit of the elevations +within the 5x5 neighbourhood surrounding each cell, this method +is considered more robust against outlier elevations (noise) +than other methods. + +For DEMs in geographic coordinate systems (i.e. angular units), the +tool uses the 3x3 polynomial fitting method for equal angle grids also +described by Florinsky (2016). +} +\examples{ +f <- system.file("extdata/dem.tif", package = "wbw") +wbw_read_raster(f) |> + wbw_maximal_curvature() +} +\references{ +For more information, see \url{https://www.whiteboxgeo.com/manual/wbw-user-manual/book/tool_help.html#maximal_curvature} + +Florinsky, I. (2016). Digital terrain analysis in soil science and +geology. Academic Press. \if{html}{\out{
}} +Florinsky, I. V. (2017). An illustrated introduction to general +geomorphometry. Progress in Physical Geography, 41(6), 723-752. \if{html}{\out{
}} +Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} +} +\seealso{ +\code{\link[=wbw_gaussian_curvature]{wbw_gaussian_curvature()}} +} +\keyword{geomorphometry} diff --git a/tests/tinytest/test_curvature.R b/tests/tinytest/test_curvature.R new file mode 100644 index 0000000..fb90f40 --- /dev/null +++ b/tests/tinytest/test_curvature.R @@ -0,0 +1,43 @@ +source("setup.R") + +# Test successful filter returns +expect_inherits( + wbw_gaussian_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") +) +expect_inherits( + wbw_maximal_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") +) + +# Test curvature alterations +# Here is near-equality check is happening. If two values are close to +# be equal, i.e. 2.222222226 and 2.222222225, then all.equal() returns TRUE +# In other cases the function will return the mean relative difference as +# a character vector +true_median <- median(x) + +expect_true( + wbw_gaussian_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_gaussian_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_maximal_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_maximal_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() +) diff --git a/tests/tinytest/test_filter.R b/tests/tinytest/test_filter.R index c307c91..c39ab7c 100644 --- a/tests/tinytest/test_filter.R +++ b/tests/tinytest/test_filter.R @@ -2,52 +2,68 @@ source("setup.R") # Test successful filter returns expect_inherits( - wbw_adaptive_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_adaptive_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_bilateral_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_bilateral_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_conservative_smoothing_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_conservative_smoothing_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_gaussian_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_gaussian_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_high_pass_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_high_pass_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_high_pass_median_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_high_pass_median_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_majority_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_majority_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_maximum_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_maximum_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_mean_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_mean_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_median_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_median_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_minimum_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_minimum_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_olympic_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_olympic_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_percentile_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_percentile_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_range_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_range_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_total_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_total_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_standard_deviation_filter(x), c("wbw::WhiteboxRaster", "S7_object") + wbw_standard_deviation_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) # Test filter alterations From ea3d157f883787016aa809f35b42e5392355ba93 Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Sun, 12 Jan 2025 11:33:54 +1300 Subject: [PATCH 2/4] lint: bump to air formatter --- CONTRIBUTING.md | 2 +- R/filters.R | 1321 ++++++++++++++++++++++------------------------- 2 files changed, 620 insertions(+), 703 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 6028516..814923e 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -33,7 +33,7 @@ See our guide on [how to create a great issue](https://code-review.tidyverse.org ### Code style * New code should follow the tidyverse [style guide](https://style.tidyverse.org). - You can use the [styler](https://CRAN.R-project.org/package=styler) package to apply these styles, but please don't restyle code that has nothing to do with your PR. + You can use the [air](https://github.com/posit-dev/air) to apply these styles, but please don't restyle code that has nothing to do with your PR. * We use [roxygen2](https://cran.r-project.org/package=roxygen2), with [Markdown syntax](https://cran.r-project.org/web/packages/roxygen2/vignettes/rd-formatting.html), for documentation. diff --git a/R/filters.R b/R/filters.R index 2955761..e2728e6 100644 --- a/R/filters.R +++ b/R/filters.R @@ -28,52 +28,48 @@ #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_adaptive_filter <- - S7::new_generic( - name = "wbw_adaptive_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L, - threshold = 2) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_adaptive_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L, - threshold = 2) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - checkmate::assert_double(threshold, len = 1) - # Filter - out <- - wbe$adaptive_filter( - raster = x@source, filter_size_x = filter_size_x, - filter_size_y = filter_size_y, threshold = threshold - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_adaptive_filter <- S7::new_generic( + name = "wbw_adaptive_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L, threshold = 2) { + S7::S7_dispatch() } +) + +S7::method(wbw_adaptive_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L, + threshold = 2 +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + checkmate::assert_double(threshold, len = 1) + # Filter + out <- wbe$adaptive_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y, + threshold = threshold + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Bilateral Filter #' @keywords image_processing @@ -116,43 +112,44 @@ S7::method(wbw_adaptive_filter, WhiteboxRaster) <- #' c("sigma_dist = 1.5", "sigma_int = 1.1")) #' #' @export -wbw_bilateral_filter <- - S7::new_generic( - name = "wbw_bilateral_filter", - dispatch_args = "x", - fun = function(x, sigma_dist = 0.75, sigma_int = 1) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_bilateral_filter, WhiteboxRaster) <- - function(x, sigma_dist = 0.75, sigma_int = 1) { - # Checks - check_env(wbe) - checkmate::assert_double( - sigma_dist, - lower = 0.5, - upper = 20, - len = 1L - ) - checkmate::assert_double( - sigma_int, - lower = 0, - len = 1L - ) - # Filter - out <- - wbe$bilateral_filter( - raster = x@source, - sigma_dist = sigma_dist, - sigma_int = sigma_int - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_bilateral_filter <- S7::new_generic( + name = "wbw_bilateral_filter", + dispatch_args = "x", + fun = function(x, sigma_dist = 0.75, sigma_int = 1) { + S7::S7_dispatch() } +) + +S7::method(wbw_bilateral_filter, WhiteboxRaster) <- function( + x, + sigma_dist = 0.75, + sigma_int = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_double( + sigma_dist, + lower = 0.5, + upper = 20, + len = 1L + ) + checkmate::assert_double( + sigma_int, + lower = 0, + len = 1L + ) + # Filter + out <- wbe$bilateral_filter( + raster = x@source, + sigma_dist = sigma_dist, + sigma_int = sigma_int + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Mean Filter #' @keywords image_processing @@ -188,50 +185,45 @@ S7::method(wbw_bilateral_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_mean_filter <- - S7::new_generic( - name = "wbw_mean_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_mean_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$mean_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_mean_filter <- S7::new_generic( + name = "wbw_mean_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() } +) + +S7::method(wbw_mean_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + # Filter + out <- wbe$mean_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Gaussian Filter #' @keywords image_processing @@ -258,38 +250,34 @@ S7::method(wbw_mean_filter, WhiteboxRaster) <- #' @eval rd_example("wbw_gaussian_filter", c("sigma = 1.5")) #' #' @export -wbw_gaussian_filter <- - S7::new_generic( - name = "wbw_gaussian_filter", - dispatch_args = "x", - fun = function(x, sigma = 0.75) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_gaussian_filter, WhiteboxRaster) <- - function(x, sigma = 0.75) { - # Checks - check_env(wbe) - checkmate::assert_double( - sigma, - lower = 0.5, - upper = 20, - len = 1L - ) - # Filter - out <- - wbe$gaussian_filter( - raster = x@source, - sigma = sigma - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_gaussian_filter <- S7::new_generic( + name = "wbw_gaussian_filter", + dispatch_args = "x", + fun = function(x, sigma = 0.75) { + S7::S7_dispatch() } +) +S7::method(wbw_gaussian_filter, WhiteboxRaster) <- function(x, sigma = 0.75) { + # Checks + check_env(wbe) + checkmate::assert_double( + sigma, + lower = 0.5, + upper = 20, + len = 1L + ) + # Filter + out <- wbe$gaussian_filter( + raster = x@source, + sigma = sigma + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Conservative Smoothing Filter #' @keywords image_processing @@ -328,51 +316,45 @@ S7::method(wbw_gaussian_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_conservative_smoothing_filter <- - S7::new_generic( - name = "wbw_conservative_smoothing_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 3L, - filter_size_y = 3L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_conservative_smoothing_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 3L, - filter_size_y = 3L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$conservative_smoothing_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_conservative_smoothing_filter <- S7::new_generic( + name = "wbw_conservative_smoothing_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 3L, filter_size_y = 3L) { + S7::S7_dispatch() } +) +S7::method(wbw_conservative_smoothing_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 3L, + filter_size_y = 3L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + # Filter + out <- wbe$conservative_smoothing_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' High Pass Filter #' @keywords image_processing @@ -402,50 +384,45 @@ S7::method(wbw_conservative_smoothing_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_high_pass_filter <- - S7::new_generic( - name = "wbw_high_pass_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_high_pass_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$high_pass_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_high_pass_filter <- S7::new_generic( + name = "wbw_high_pass_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() } +) + +S7::method(wbw_high_pass_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + # Filter + out <- wbe$high_pass_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' High Pass Median Filter #' @keywords image_processing @@ -477,59 +454,52 @@ S7::method(wbw_high_pass_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_high_pass_median_filter <- - S7::new_generic( - name = "wbw_high_pass_median_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L, - sig_digits = 2L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_high_pass_median_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L, - sig_digits = 2L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - sig_digits <- - checkmate::asInteger( - sig_digits, - lower = 0L, - len = 1L - ) - # Filter - out <- - wbe$high_pass_median_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y, - sig_digits = sig_digits - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_high_pass_median_filter <- S7::new_generic( + name = "wbw_high_pass_median_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L, sig_digits = 2L) { + S7::S7_dispatch() } +) + +S7::method(wbw_high_pass_median_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L, + sig_digits = 2L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + sig_digits <- checkmate::asInteger( + sig_digits, + lower = 0L, + len = 1L + ) + # Filter + out <- wbe$high_pass_median_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y, + sig_digits = sig_digits + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Median Filter #' @keywords image_processing @@ -574,59 +544,52 @@ S7::method(wbw_high_pass_median_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_median_filter <- - S7::new_generic( - name = "wbw_median_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L, - sig_digits = 2L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_median_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L, - sig_digits = 2L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - sig_digits <- - checkmate::asInteger( - sig_digits, - lower = 0L, - len = 1L - ) - # Filter - out <- - wbe$median_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y, - sig_digits = sig_digits - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_median_filter <- S7::new_generic( + name = "wbw_median_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L, sig_digits = 2L) { + S7::S7_dispatch() } +) + +S7::method(wbw_median_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L, + sig_digits = 2L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + sig_digits <- checkmate::asInteger( + sig_digits, + lower = 0L, + len = 1L + ) + # Filter + out <- wbe$median_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y, + sig_digits = sig_digits + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Majority Filter #' @keywords image_processing @@ -654,52 +617,46 @@ S7::method(wbw_median_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_majority_filter <- - S7::new_generic( - name = "wbw_majority_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_majority_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - - # Filter - out <- - wbe$majority_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_majority_filter <- S7::new_generic( + name = "wbw_majority_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() } +) + +S7::method(wbw_majority_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + # Filter + out <- wbe$majority_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Maximum Filter #' @keywords image_processing @@ -727,52 +684,46 @@ S7::method(wbw_majority_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_maximum_filter <- - S7::new_generic( - name = "wbw_maximum_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_maximum_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - - # Filter - out <- - wbe$maximum_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_maximum_filter <- S7::new_generic( + name = "wbw_maximum_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() } +) +S7::method(wbw_maximum_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + + # Filter + out <- wbe$maximum_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Minimum Filter #' @keywords image_processing @@ -800,51 +751,46 @@ S7::method(wbw_maximum_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_minimum_filter <- - S7::new_generic( - name = "wbw_minimum_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) +wbw_minimum_filter <- S7::new_generic( + name = "wbw_minimum_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() + } +) -S7::method(wbw_minimum_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) +S7::method(wbw_minimum_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$minimum_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) - } + # Filter + out <- wbe$minimum_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Olympic Filter #' @keywords image_processing @@ -875,52 +821,46 @@ S7::method(wbw_minimum_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_olympic_filter <- - S7::new_generic( - name = "wbw_olympic_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_olympic_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - - # Filter - out <- - wbe$olympic_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_olympic_filter <- S7::new_generic( + name = "wbw_olympic_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() } +) +S7::method(wbw_olympic_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + + # Filter + out <- wbe$olympic_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Percentile Filter #' @keywords image_processing @@ -971,60 +911,52 @@ S7::method(wbw_olympic_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_percentile_filter <- - S7::new_generic( - name = "wbw_percentile_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L, - sig_digits = 2L) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_percentile_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L, - sig_digits = 2L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) - sig_digits <- - checkmate::asInteger( - sig_digits, - lower = 0L, - len = 1L - ) - # Filter - out <- - wbe$percentile_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y, - sig_digits = sig_digits - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) +wbw_percentile_filter <- S7::new_generic( + name = "wbw_percentile_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L, sig_digits = 2L) { + S7::S7_dispatch() } +) +S7::method(wbw_percentile_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L, + sig_digits = 2L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) + sig_digits <- checkmate::asInteger( + sig_digits, + lower = 0L, + len = 1L + ) + # Filter + out <- wbe$percentile_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y, + sig_digits = sig_digits + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Range Filter #' @keywords image_processing @@ -1052,51 +984,46 @@ S7::method(wbw_percentile_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_range_filter <- - S7::new_generic( - name = "wbw_range_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) +wbw_range_filter <- S7::new_generic( + name = "wbw_range_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() + } +) -S7::method(wbw_range_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) +S7::method(wbw_range_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$range_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) - } + # Filter + out <- wbe$range_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Total Filter #' @keywords image_processing @@ -1124,58 +1051,53 @@ S7::method(wbw_range_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_total_filter <- - S7::new_generic( - name = "wbw_total_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) +wbw_total_filter <- S7::new_generic( + name = "wbw_total_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() + } +) -S7::method(wbw_total_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) +S7::method(wbw_total_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$total_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) - } + # Filter + out <- wbe$total_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} #' Standard Deviation Filter #' @keywords image_processing #' #' @description -#' A standard deviation filter assigns to each cell in the output grid the -#' standard deviation, a measure of dispersion, of the values contained within +#' A standard deviation filter assigns to each cell in the output grid the +#' standard deviation, a measure of dispersion, of the values contained within #' a moving window centred on each grid cell. #' #' @details @@ -1197,48 +1119,43 @@ S7::method(wbw_total_filter, WhiteboxRaster) <- #' c("filter_size_x = 3L", "filter_size_y = 3L")) #' #' @export -wbw_standard_deviation_filter <- - S7::new_generic( - name = "wbw_standard_deviation_filter", - dispatch_args = "x", - fun = function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - S7::S7_dispatch() - } - ) +wbw_standard_deviation_filter <- S7::new_generic( + name = "wbw_standard_deviation_filter", + dispatch_args = "x", + fun = function(x, filter_size_x = 11L, filter_size_y = 11L) { + S7::S7_dispatch() + } +) -S7::method(wbw_standard_deviation_filter, WhiteboxRaster) <- - function(x, - filter_size_x = 11L, - filter_size_y = 11L) { - # Checks - check_env(wbe) - filter_size_x <- - checkmate::asInteger( - filter_size_x, - lower = 0L, - len = 1L - ) - filter_size_y <- - checkmate::asInteger( - filter_size_y, - lower = 0L, - len = 1L - ) - checkmate::assert_true(filter_size_x %% 2 == 1) - checkmate::assert_true(filter_size_y %% 2 == 1) +S7::method(wbw_standard_deviation_filter, WhiteboxRaster) <- function( + x, + filter_size_x = 11L, + filter_size_y = 11L +) { + # Checks + check_env(wbe) + filter_size_x <- checkmate::asInteger( + filter_size_x, + lower = 0L, + len = 1L + ) + filter_size_y <- checkmate::asInteger( + filter_size_y, + lower = 0L, + len = 1L + ) + checkmate::assert_true(filter_size_x %% 2 == 1) + checkmate::assert_true(filter_size_y %% 2 == 1) - # Filter - out <- - wbe$standard_deviation_filter( - raster = x@source, - filter_size_x = filter_size_x, - filter_size_y = filter_size_y - ) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) - } + # Filter + out <- wbe$standard_deviation_filter( + raster = x@source, + filter_size_x = filter_size_x, + filter_size_y = filter_size_y + ) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} From 2469a7e68853697b4d6617a4bf7f19785608238f Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Sun, 12 Jan 2025 11:49:06 +1300 Subject: [PATCH 3/4] feat: min mean and profile curvatures --- NAMESPACE | 3 + R/curvature.R | 278 +++++++++++++++++++++++++++++++- man/wbw_gaussian_curvature.Rd | 2 +- man/wbw_maximal_curvature.Rd | 4 +- man/wbw_mean_curvature.Rd | 69 ++++++++ man/wbw_minimal_curvature.Rd | 72 +++++++++ man/wbw_profile_curvature.Rd | 77 +++++++++ tests/tinytest/test_curvature.R | 48 ++++++ 8 files changed, 547 insertions(+), 6 deletions(-) create mode 100644 man/wbw_mean_curvature.Rd create mode 100644 man/wbw_minimal_curvature.Rd create mode 100644 man/wbw_profile_curvature.Rd diff --git a/NAMESPACE b/NAMESPACE index d432d67..e524ff2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,12 +44,15 @@ export(wbw_majority_filter) export(wbw_max_procs) export(wbw_maximal_curvature) export(wbw_maximum_filter) +export(wbw_mean_curvature) export(wbw_mean_filter) export(wbw_median_filter) +export(wbw_minimal_curvature) export(wbw_minimum_filter) export(wbw_multidirectional_hillshade) export(wbw_olympic_filter) export(wbw_percentile_filter) +export(wbw_profile_curvature) export(wbw_random_sample) export(wbw_range_filter) export(wbw_read_raster) diff --git a/R/curvature.R b/R/curvature.R index 20d3f9c..3d1ec2a 100644 --- a/R/curvature.R +++ b/R/curvature.R @@ -50,7 +50,7 @@ #' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental #' quantitative methods of land surface analysis. Geoderma 107: 1–32.
#' -#' @seealso [wbw_maximal_curvature()] +#' @seealso [wbw_maximal_curvature()], [wbw_minimal_curvature()] #' #' @eval rd_example("wbw_gaussian_curvature") #' @@ -98,7 +98,7 @@ S7::method(wbw_gaussian_curvature, WhiteboxRaster) <- function( #' and positive values correspond to ridge positions while negative values #' are indicative of closed depressions (Florinsky, 2016). #' -#' Gaussian curvature is measured in units of \eqn{m^{-1}}. +#' Maximal curvature is measured in units of \eqn{m^{-1}}. #' #' @details #' Curvature values are often very small and as such the user may opt to @@ -140,7 +140,7 @@ S7::method(wbw_gaussian_curvature, WhiteboxRaster) <- function( #' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental #' quantitative methods of land surface analysis. Geoderma 107: 1–32.
#' -#' @seealso [wbw_gaussian_curvature()] +#' @seealso [wbw_gaussian_curvature()], [wbw_minimal_curvature()] #' #' @eval rd_example("wbw_maximal_curvature") #' @@ -176,3 +176,275 @@ S7::method(wbw_maximal_curvature, WhiteboxRaster) <- function( source = out ) } + +#' Minimal Curvature +#' @keywords geomorphometry +#' +#' @description +#' This tool calculates the minimal curvature from a digital elevation model +#' (\eqn{dem}). Minimal curvature is the curvature of a principal section +#' with the highest value of curvature at a given point of the topographic +#' surface (Florinsky, 2017). The values of this curvature are unbounded, +#' and positive values correspond to ridge positions while negative values +#' are indicative of closed depressions (Florinsky, 2016). +#' +#' Minimal curvature is measured in units of \eqn{m^{-1}}. +#' +#' @details +#' Curvature values are often very small and as such the user may opt to +#' log-transform the output raster (\eqn{log_transform}). Transforming +#' the values applies the equation by Shary et al. (2002): +#' +#' \deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} +#' +#' where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +#' grid cell size. +#' +#' For DEMs in projected coordinate systems, the tool uses the +#' 3rd-order bivariate Taylor polynomial method described by +#' Florinsky (2016). Based on a polynomial fit of the elevations +#' within the 5x5 neighbourhood surrounding each cell, this method +#' is considered more robust against outlier elevations (noise) +#' than other methods. +#' +#' For DEMs in geographic coordinate systems (i.e. angular units), the +#' tool uses the 3x3 polynomial fitting method for equal angle grids also +#' described by Florinsky (2016). +#' +#' @eval rd_input_raster("dem") +#' @param log_transform \code{logical}, default \code{FALSE}. Wheter +#' log-transform the output raster or not. See details. +#' @param z_factor \code{double}, Z conversion factor is only important +#' when the vertical and horizontal units are not the same in the DEM. +#' When this is the case, the algorithm will multiply each elevation in the +#' DEM by the Z conversion factor +#' +#' @return [WhiteboxRaster] object in units of \eqn{m^{-1}}. +#' +#' @eval rd_wbw_link("minimal_curvature") +#' @references +#' Florinsky, I. (2016). Digital terrain analysis in soil science and +#' geology. Academic Press.
+#' Florinsky, I. V. (2017). An illustrated introduction to general +#' geomorphometry. Progress in Physical Geography, 41(6), 723-752.
+#' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +#' quantitative methods of land surface analysis. Geoderma 107: 1–32.
+#' +#' @seealso [wbw_gaussian_curvature()], [wbw_maximal_curvature()] +#' +#' @eval rd_example("wbw_minimal_curvature") +#' +#' @export +wbw_minimal_curvature <- S7::new_generic( + name = "wbw_minimal_curvature", + dispatch_args = "dem", + fun = function(dem, log_transform = FALSE, z_factor = 1) { + S7::S7_dispatch() + } +) + +S7::method(wbw_minimal_curvature, WhiteboxRaster) <- function( + dem, + log_transform = FALSE, + z_factor = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_logical(log_transform, len = 1) + checkmate::assert_double(z_factor, len = 1) + + # WBT + out <- wbe$minimal_curvature( + dem = dem@source, + log_transform = log_transform, + z_factor = z_factor + ) + + # Return + WhiteboxRaster( + name = "Minimal Curvature", + source = out + ) +} + +#' Mean Curvature +#' @keywords geomorphometry +#' +#' @description +#' This tool calculates the mean curvature from a digital elevation +#' model (\eqn{dem}). +#' +#' WhiteboxTools reports curvature in radians multiplied by 100 for easier +#' interpretation because curvature values are typically very small. +#' +#' @details +#' Curvature values are often very small and as such the user may opt to +#' log-transform the output raster (\eqn{log_transform}). Transforming +#' the values applies the equation by Shary et al. (2002): +#' +#' \deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} +#' +#' where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +#' grid cell size. +#' +#' For DEMs in projected coordinate systems, the tool uses the +#' 3rd-order bivariate Taylor polynomial method described by +#' Florinsky (2016). Based on a polynomial fit of the elevations +#' within the 5x5 neighbourhood surrounding each cell, this method +#' is considered more robust against outlier elevations (noise) +#' than other methods. +#' +#' For DEMs in geographic coordinate systems (i.e. angular units), the +#' tool uses the 3x3 polynomial fitting method for equal angle grids also +#' described by Florinsky (2016). +#' +#' @eval rd_input_raster("dem") +#' @param log_transform \code{logical}, default \code{FALSE}. Wheter +#' log-transform the output raster or not. See details. +#' @param z_factor \code{double}, Z conversion factor is only important +#' when the vertical and horizontal units are not the same in the DEM. +#' When this is the case, the algorithm will multiply each elevation in the +#' DEM by the Z conversion factor +#' +#' @return [WhiteboxRaster] object. +#' +#' @eval rd_wbw_link("mean_curvature") +#' @references +#' Florinsky, I. (2016). Digital terrain analysis in soil science and +#' geology. Academic Press.
+#' Florinsky, I. V. (2017). An illustrated introduction to general +#' geomorphometry. Progress in Physical Geography, 41(6), 723-752.
+#' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +#' quantitative methods of land surface analysis. Geoderma 107: 1–32.
+#' +#' @seealso [wbw_gaussian_curvature()], [wbw_maximal_curvature()] +#' +#' @eval rd_example("wbw_mean_curvature") +#' +#' @export +wbw_mean_curvature <- S7::new_generic( + name = "wbw_mean_curvature", + dispatch_args = "dem", + fun = function(dem, log_transform = FALSE, z_factor = 1) { + S7::S7_dispatch() + } +) + +S7::method(wbw_mean_curvature, WhiteboxRaster) <- function( + dem, + log_transform = FALSE, + z_factor = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_logical(log_transform, len = 1) + checkmate::assert_double(z_factor, len = 1) + + # WBT + out <- wbe$mean_curvature( + dem = dem@source, + log_transform = log_transform, + z_factor = z_factor + ) + + # Return + WhiteboxRaster( + name = "Mean Curvature", + source = out + ) +} + +#' Profile Curvature +#' @keywords geomorphometry +#' +#' @description +#' This tool calculates the profile curvature from a digital elevation +#' model (\eqn{dem}), or the rate of change in slope along a flow line. +#' +#' Curvature is the second derivative of the topographic surface defined +#' by a DEM. Profile curvature characterizes the degree of downslope +#' acceleration or deceleration within the +#' landscape (Gallant and Wilson, 2000). +#' +#' WhiteboxTools reports curvature in radians multiplied by 100 for easier +#' interpretation because curvature values are typically very small. +#' +#' @details +#' Curvature values are often very small and as such the user may opt to +#' log-transform the output raster (\eqn{log_transform}). Transforming +#' the values applies the equation by Shary et al. (2002): +#' +#' \deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} +#' +#' where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +#' grid cell size. +#' +#' For DEMs in projected coordinate systems, the tool uses the +#' 3rd-order bivariate Taylor polynomial method described by +#' Florinsky (2016). Based on a polynomial fit of the elevations +#' within the 5x5 neighbourhood surrounding each cell, this method +#' is considered more robust against outlier elevations (noise) +#' than other methods. +#' +#' For DEMs in geographic coordinate systems (i.e. angular units), the +#' tool uses the 3x3 polynomial fitting method for equal angle grids also +#' described by Florinsky (2016). +#' +#' @eval rd_input_raster("dem") +#' @param log_transform \code{logical}, default \code{FALSE}. Wheter +#' log-transform the output raster or not. See details. +#' @param z_factor \code{double}, Z conversion factor is only important +#' when the vertical and horizontal units are not the same in the DEM. +#' When this is the case, the algorithm will multiply each elevation in the +#' DEM by the Z conversion factor +#' +#' @return [WhiteboxRaster] object. +#' +#' @eval rd_wbw_link("profile_curvature") +#' @references +#' Gallant, J. C., and J. P. Wilson, 2000, Primary topographic attributes, +#' in Terrain Analysis: Principles and Applications, edited by J. P. +#' Wilson and J. C. Gallant pp. 51-86, John Wiley, Hoboken, N.J.
+#' Florinsky, I. (2016). Digital terrain analysis in soil science and +#' geology. Academic Press.
+#' Florinsky, I. V. (2017). An illustrated introduction to general +#' geomorphometry. Progress in Physical Geography, 41(6), 723-752.
+#' Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +#' quantitative methods of land surface analysis. Geoderma 107: 1–32.
+#' +#' @seealso [wbw_gaussian_curvature()], [wbw_mean_curvature()] +#' +#' @eval rd_example("wbw_profile_curvature") +#' +#' @export +wbw_profile_curvature <- S7::new_generic( + name = "wbw_profile_curvature", + dispatch_args = "dem", + fun = function(dem, log_transform = FALSE, z_factor = 1) { + S7::S7_dispatch() + } +) + +S7::method(wbw_profile_curvature, WhiteboxRaster) <- function( + dem, + log_transform = FALSE, + z_factor = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_logical(log_transform, len = 1) + checkmate::assert_double(z_factor, len = 1) + + # WBT + out <- wbe$profile_curvature( + dem = dem@source, + log_transform = log_transform, + z_factor = z_factor + ) + + # Return + WhiteboxRaster( + name = "Profile Curvature", + source = out + ) +} diff --git a/man/wbw_gaussian_curvature.Rd b/man/wbw_gaussian_curvature.Rd index 2d85676..3ca1e6f 100644 --- a/man/wbw_gaussian_curvature.Rd +++ b/man/wbw_gaussian_curvature.Rd @@ -66,6 +66,6 @@ Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} } \seealso{ -\code{\link[=wbw_maximal_curvature]{wbw_maximal_curvature()}} +\code{\link[=wbw_maximal_curvature]{wbw_maximal_curvature()}}, \code{\link[=wbw_minimal_curvature]{wbw_minimal_curvature()}} } \keyword{geomorphometry} diff --git a/man/wbw_maximal_curvature.Rd b/man/wbw_maximal_curvature.Rd index 6039f64..4e6d027 100644 --- a/man/wbw_maximal_curvature.Rd +++ b/man/wbw_maximal_curvature.Rd @@ -28,7 +28,7 @@ surface (Florinsky, 2017). The values of this curvature are unbounded, and positive values correspond to ridge positions while negative values are indicative of closed depressions (Florinsky, 2016). -Gaussian curvature is measured in units of \eqn{m^{-1}}. +Maximal curvature is measured in units of \eqn{m^{-1}}. } \details{ Curvature values are often very small and as such the user may opt to @@ -67,6 +67,6 @@ Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} } \seealso{ -\code{\link[=wbw_gaussian_curvature]{wbw_gaussian_curvature()}} +\code{\link[=wbw_gaussian_curvature]{wbw_gaussian_curvature()}}, \code{\link[=wbw_minimal_curvature]{wbw_minimal_curvature()}} } \keyword{geomorphometry} diff --git a/man/wbw_mean_curvature.Rd b/man/wbw_mean_curvature.Rd new file mode 100644 index 0000000..2b10527 --- /dev/null +++ b/man/wbw_mean_curvature.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/curvature.R +\name{wbw_mean_curvature} +\alias{wbw_mean_curvature} +\title{Mean Curvature} +\usage{ +wbw_mean_curvature(dem, log_transform = FALSE, z_factor = 1) +} +\arguments{ +\item{dem}{Raster object of class \link{WhiteboxRaster}. See \code{\link[=wbw_read_raster]{wbw_read_raster()}} for more details.} + +\item{log_transform}{\code{logical}, default \code{FALSE}. Wheter +log-transform the output raster or not. See details.} + +\item{z_factor}{\code{double}, Z conversion factor is only important +when the vertical and horizontal units are not the same in the DEM. +When this is the case, the algorithm will multiply each elevation in the +DEM by the Z conversion factor} +} +\value{ +\link{WhiteboxRaster} object. +} +\description{ +This tool calculates the mean curvature from a digital elevation +model (\eqn{dem}). + +WhiteboxTools reports curvature in radians multiplied by 100 for easier +interpretation because curvature values are typically very small. +} +\details{ +Curvature values are often very small and as such the user may opt to +log-transform the output raster (\eqn{log_transform}). Transforming +the values applies the equation by Shary et al. (2002): + +\deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} + +where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +grid cell size. + +For DEMs in projected coordinate systems, the tool uses the +3rd-order bivariate Taylor polynomial method described by +Florinsky (2016). Based on a polynomial fit of the elevations +within the 5x5 neighbourhood surrounding each cell, this method +is considered more robust against outlier elevations (noise) +than other methods. + +For DEMs in geographic coordinate systems (i.e. angular units), the +tool uses the 3x3 polynomial fitting method for equal angle grids also +described by Florinsky (2016). +} +\examples{ +f <- system.file("extdata/dem.tif", package = "wbw") +wbw_read_raster(f) |> + wbw_mean_curvature() +} +\references{ +For more information, see \url{https://www.whiteboxgeo.com/manual/wbw-user-manual/book/tool_help.html#mean_curvature} + +Florinsky, I. (2016). Digital terrain analysis in soil science and +geology. Academic Press. \if{html}{\out{
}} +Florinsky, I. V. (2017). An illustrated introduction to general +geomorphometry. Progress in Physical Geography, 41(6), 723-752. \if{html}{\out{
}} +Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} +} +\seealso{ +\code{\link[=wbw_gaussian_curvature]{wbw_gaussian_curvature()}}, \code{\link[=wbw_maximal_curvature]{wbw_maximal_curvature()}} +} +\keyword{geomorphometry} diff --git a/man/wbw_minimal_curvature.Rd b/man/wbw_minimal_curvature.Rd new file mode 100644 index 0000000..2723e5d --- /dev/null +++ b/man/wbw_minimal_curvature.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/curvature.R +\name{wbw_minimal_curvature} +\alias{wbw_minimal_curvature} +\title{Minimal Curvature} +\usage{ +wbw_minimal_curvature(dem, log_transform = FALSE, z_factor = 1) +} +\arguments{ +\item{dem}{Raster object of class \link{WhiteboxRaster}. See \code{\link[=wbw_read_raster]{wbw_read_raster()}} for more details.} + +\item{log_transform}{\code{logical}, default \code{FALSE}. Wheter +log-transform the output raster or not. See details.} + +\item{z_factor}{\code{double}, Z conversion factor is only important +when the vertical and horizontal units are not the same in the DEM. +When this is the case, the algorithm will multiply each elevation in the +DEM by the Z conversion factor} +} +\value{ +\link{WhiteboxRaster} object in units of \eqn{m^{-1}}. +} +\description{ +This tool calculates the minimal curvature from a digital elevation model +(\eqn{dem}). Minimal curvature is the curvature of a principal section +with the highest value of curvature at a given point of the topographic +surface (Florinsky, 2017). The values of this curvature are unbounded, +and positive values correspond to ridge positions while negative values +are indicative of closed depressions (Florinsky, 2016). + +Minimal curvature is measured in units of \eqn{m^{-1}}. +} +\details{ +Curvature values are often very small and as such the user may opt to +log-transform the output raster (\eqn{log_transform}). Transforming +the values applies the equation by Shary et al. (2002): + +\deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} + +where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +grid cell size. + +For DEMs in projected coordinate systems, the tool uses the +3rd-order bivariate Taylor polynomial method described by +Florinsky (2016). Based on a polynomial fit of the elevations +within the 5x5 neighbourhood surrounding each cell, this method +is considered more robust against outlier elevations (noise) +than other methods. + +For DEMs in geographic coordinate systems (i.e. angular units), the +tool uses the 3x3 polynomial fitting method for equal angle grids also +described by Florinsky (2016). +} +\examples{ +f <- system.file("extdata/dem.tif", package = "wbw") +wbw_read_raster(f) |> + wbw_minimal_curvature() +} +\references{ +For more information, see \url{https://www.whiteboxgeo.com/manual/wbw-user-manual/book/tool_help.html#minimal_curvature} + +Florinsky, I. (2016). Digital terrain analysis in soil science and +geology. Academic Press. \if{html}{\out{
}} +Florinsky, I. V. (2017). An illustrated introduction to general +geomorphometry. Progress in Physical Geography, 41(6), 723-752. \if{html}{\out{
}} +Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} +} +\seealso{ +\code{\link[=wbw_gaussian_curvature]{wbw_gaussian_curvature()}}, \code{\link[=wbw_maximal_curvature]{wbw_maximal_curvature()}} +} +\keyword{geomorphometry} diff --git a/man/wbw_profile_curvature.Rd b/man/wbw_profile_curvature.Rd new file mode 100644 index 0000000..5688522 --- /dev/null +++ b/man/wbw_profile_curvature.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/curvature.R +\name{wbw_profile_curvature} +\alias{wbw_profile_curvature} +\title{Profile Curvature} +\usage{ +wbw_profile_curvature(dem, log_transform = FALSE, z_factor = 1) +} +\arguments{ +\item{dem}{Raster object of class \link{WhiteboxRaster}. See \code{\link[=wbw_read_raster]{wbw_read_raster()}} for more details.} + +\item{log_transform}{\code{logical}, default \code{FALSE}. Wheter +log-transform the output raster or not. See details.} + +\item{z_factor}{\code{double}, Z conversion factor is only important +when the vertical and horizontal units are not the same in the DEM. +When this is the case, the algorithm will multiply each elevation in the +DEM by the Z conversion factor} +} +\value{ +\link{WhiteboxRaster} object. +} +\description{ +This tool calculates the profile curvature from a digital elevation +model (\eqn{dem}), or the rate of change in slope along a flow line. + +Curvature is the second derivative of the topographic surface defined +by a DEM. Profile curvature characterizes the degree of downslope +acceleration or deceleration within the +landscape (Gallant and Wilson, 2000). + +WhiteboxTools reports curvature in radians multiplied by 100 for easier +interpretation because curvature values are typically very small. +} +\details{ +Curvature values are often very small and as such the user may opt to +log-transform the output raster (\eqn{log_transform}). Transforming +the values applies the equation by Shary et al. (2002): + +\deqn{Θ' = sign(Θ) ln(1 + 10^n|Θ|)} + +where \eqn{Θ} is the parameter value and \eqn{n} is dependent on the +grid cell size. + +For DEMs in projected coordinate systems, the tool uses the +3rd-order bivariate Taylor polynomial method described by +Florinsky (2016). Based on a polynomial fit of the elevations +within the 5x5 neighbourhood surrounding each cell, this method +is considered more robust against outlier elevations (noise) +than other methods. + +For DEMs in geographic coordinate systems (i.e. angular units), the +tool uses the 3x3 polynomial fitting method for equal angle grids also +described by Florinsky (2016). +} +\examples{ +f <- system.file("extdata/dem.tif", package = "wbw") +wbw_read_raster(f) |> + wbw_profile_curvature() +} +\references{ +For more information, see \url{https://www.whiteboxgeo.com/manual/wbw-user-manual/book/tool_help.html#profile_curvature} + +Gallant, J. C., and J. P. Wilson, 2000, Primary topographic attributes, +in Terrain Analysis: Principles and Applications, edited by J. P. +Wilson and J. C. Gallant pp. 51-86, John Wiley, Hoboken, N.J. \if{html}{\out{
}} +Florinsky, I. (2016). Digital terrain analysis in soil science and +geology. Academic Press. \if{html}{\out{
}} +Florinsky, I. V. (2017). An illustrated introduction to general +geomorphometry. Progress in Physical Geography, 41(6), 723-752. \if{html}{\out{
}} +Shary P. A., Sharaya L. S. and Mitusov A. V. (2002) Fundamental +quantitative methods of land surface analysis. Geoderma 107: 1–32. \if{html}{\out{
}} +} +\seealso{ +\code{\link[=wbw_gaussian_curvature]{wbw_gaussian_curvature()}}, \code{\link[=wbw_mean_curvature]{wbw_mean_curvature()}} +} +\keyword{geomorphometry} diff --git a/tests/tinytest/test_curvature.R b/tests/tinytest/test_curvature.R index fb90f40..b4d4660 100644 --- a/tests/tinytest/test_curvature.R +++ b/tests/tinytest/test_curvature.R @@ -9,6 +9,18 @@ expect_inherits( wbw_maximal_curvature(x), c("wbw::WhiteboxRaster", "S7_object") ) +expect_inherits( + wbw_minimal_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") +) +expect_inherits( + wbw_mean_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") +) +expect_inherits( + wbw_profile_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") +) # Test curvature alterations # Here is near-equality check is happening. If two values are close to @@ -41,3 +53,39 @@ expect_true( all.equal(true_median) |> is.character() ) +expect_true( + wbw_minimal_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_minimal_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_mean_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_mean_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_profile_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() +) +expect_true( + wbw_profile_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() +) From 5b16ba95daa835f600b97c3d40d54b294117e584 Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Sun, 12 Jan 2025 11:59:12 +1300 Subject: [PATCH 4/4] lint: bump to air formatter --- R/WhiteboxClasses.R | 159 ++++++------ R/checks.R | 72 +++--- R/conversion.R | 83 +++--- R/crs.R | 38 ++- R/dimensions.R | 292 ++++++++++------------ R/geomorphometry.R | 211 ++++++++-------- R/hillshade.R | 160 ++++++------ R/installation.R | 124 ++++----- R/math.R | 60 +++-- R/matrix.R | 40 ++- R/plot.R | 31 ++- R/print.R | 8 +- R/summary.R | 67 +++-- R/system.R | 168 ++++++------- R/terra.R | 218 ++++++++-------- R/utils_documentation.R | 83 +++--- R/write.R | 38 +-- R/zzz.R | 74 +++--- man/wbw_hillshade.Rd | 2 +- man/wbw_multidirectional_hillshade.Rd | 2 +- tests/tinytest/setup.R | 12 +- tests/tinytest/test_checks.R | 12 +- tests/tinytest/test_conversions.R | 2 +- tests/tinytest/test_crs.R | 2 +- tests/tinytest/test_curvature.R | 100 ++++---- tests/tinytest/test_filter.R | 206 +++++++-------- tests/tinytest/test_geomorphometry.R | 11 +- tests/tinytest/test_io.R | 48 ++-- tests/tinytest/test_math.R | 7 +- tests/tinytest/test_primitives.R | 2 - tests/tinytest/test_print.R | 33 ++- tests/tinytest/test_terra.R | 20 +- tests/tinytest/test_utils_documentation.R | 42 ++-- 33 files changed, 1200 insertions(+), 1227 deletions(-) diff --git a/R/WhiteboxClasses.R b/R/WhiteboxClasses.R index a47a9ab..48b3002 100644 --- a/R/WhiteboxClasses.R +++ b/R/WhiteboxClasses.R @@ -2,7 +2,7 @@ #' @keywords class #' #' @description -#' Defines the spatial extent of a raster dataset using coordinates for +#' Defines the spatial extent of a raster dataset using coordinates for #' the west, east, south, and north boundaries. #' #' @param west \code{double} Western boundary coordinate @@ -11,46 +11,44 @@ #' @param north \code{double} Northern boundary coordinate #' #' @export -WhiteboxExtent <- - S7::new_class( - name = "WhiteboxExtent", - package = "wbw", - properties = list( - west = S7::new_property( - class = S7::class_double, - validator = function(value) { - if (length(value) != 1) { - return("'west' must be a single numeric value") - } +WhiteboxExtent <- S7::new_class( + name = "WhiteboxExtent", + package = "wbw", + properties = list( + west = S7::new_property( + class = S7::class_double, + validator = function(value) { + if (length(value) != 1) { + return("'west' must be a single numeric value") } - ), - east = S7::new_property( - class = S7::class_double, - validator = function(value) { - if (length(value) != 1) { - return("'east' must be a single numeric value") - } + } + ), + east = S7::new_property( + class = S7::class_double, + validator = function(value) { + if (length(value) != 1) { + return("'east' must be a single numeric value") } - ), - south = S7::new_property( - class = S7::class_double, - validator = function(value) { - if (length(value) != 1) { - return("'south' must be a single numeric value") - } + } + ), + south = S7::new_property( + class = S7::class_double, + validator = function(value) { + if (length(value) != 1) { + return("'south' must be a single numeric value") } - ), - north = S7::new_property( - class = S7::class_double, - validator = function(value) { - if (length(value) != 1) { - return("'north' must be a single numeric value") - } + } + ), + north = S7::new_property( + class = S7::class_double, + validator = function(value) { + if (length(value) != 1) { + return("'north' must be a single numeric value") } - ) + } ) ) - +) #' WhiteboxRaster Class #' @keywords class @@ -71,53 +69,52 @@ WhiteboxExtent <- #' \item{extent}{\code{WhiteboxExtent} Spatial extent of the raster} #' } #' @export -WhiteboxRaster <- - S7::new_class( - name = "WhiteboxRaster", - package = "wbw", - properties = list( - name = S7::class_character, - source = S7::class_any, - stats = S7::new_property( - class = S7::class_character, - getter = function(self) { - check_env(wbe) - wbe$raster_summary_stats(self@source) - } - ), - min = S7::new_property( - class = S7::class_double, - getter = function(self) { - extract_stat(self@stats, "minimum") - }, - validator = function(value) { - if (!is.numeric(value) || length(value) != 1) { - return("@min must be a single numeric value") - } +WhiteboxRaster <- S7::new_class( + name = "WhiteboxRaster", + package = "wbw", + properties = list( + name = S7::class_character, + source = S7::class_any, + stats = S7::new_property( + class = S7::class_character, + getter = function(self) { + check_env(wbe) + wbe$raster_summary_stats(self@source) + } + ), + min = S7::new_property( + class = S7::class_double, + getter = function(self) { + extract_stat(self@stats, "minimum") + }, + validator = function(value) { + if (!is.numeric(value) || length(value) != 1) { + return("@min must be a single numeric value") } - ), - max = S7::new_property( - class = S7::class_double, - getter = function(self) { - extract_stat(self@stats, "maximum") - }, - validator = function(value) { - if (!is.numeric(value) || length(value) != 1) { - return("@max must be a single numeric value") - } + } + ), + max = S7::new_property( + class = S7::class_double, + getter = function(self) { + extract_stat(self@stats, "maximum") + }, + validator = function(value) { + if (!is.numeric(value) || length(value) != 1) { + return("@max must be a single numeric value") } - ) - # extent = S7::new_property( - # class = WhiteboxExtent, - # getter = function(self) { - # conf <- self@source$configs - # WhiteboxExtent( - # west = conf$west, - # east = conf$east, - # south = conf$south, - # north = conf$north - # ) - # } - # ) + } ) + # extent = S7::new_property( + # class = WhiteboxExtent, + # getter = function(self) { + # conf <- self@source$configs + # WhiteboxExtent( + # west = conf$west, + # east = conf$east, + # south = conf$south, + # north = conf$north + # ) + # } + # ) ) +) diff --git a/R/checks.R b/R/checks.R index b62b3b6..ea3b344 100644 --- a/R/checks.R +++ b/R/checks.R @@ -1,51 +1,53 @@ #' Check if package is installed #' @rdname checks #' @keywords internal -check_package <- - function(package) { - if (!requireNamespace(package, quietly = TRUE)) { - stop(paste(package, "is required but not installed.")) - } +check_package <- function(package) { + if (!requireNamespace(package, quietly = TRUE)) { + stop(paste(package, "is required but not installed.")) } +} #' Check if whitebox environment is present #' @rdname checks #' @keywords internal -check_env <- - function(env = wbe) { - checkmate::assert_class( - env, - classes = c( - "whitebox_workflows.WbEnvironment", - "python.builtin.WbEnvironmentBase", - "python.builtin.object" - ) +check_env <- function(env = wbe) { + checkmate::assert_class( + env, + classes = c( + "whitebox_workflows.WbEnvironment", + "python.builtin.WbEnvironmentBase", + "python.builtin.object" ) - } + ) +} #' Check input file extension #' @rdname checks #' @keywords internal -check_input_file <- - function(file_name, type) { - type <- checkmate::matchArg(type, c("vector", "raster")) +check_input_file <- function(file_name, type) { + type <- checkmate::matchArg(type, c("vector", "raster")) - if (type == "vector") { - checkmate::assertFileExists( - file_name, - access = "r", - extension = c(".shp") - ) - } else if (type == "raster") { - checkmate::assertFileExists( - file_name, - access = "r", - extension = c( - ".tif", ".tiff", ".sdat", ".sgrd", ".rst", - ".rdc", ".grd", ".flt", ".bil" - ) + if (type == "vector") { + checkmate::assertFileExists( + file_name, + access = "r", + extension = c(".shp") + ) + } else if (type == "raster") { + checkmate::assertFileExists( + file_name, + access = "r", + extension = c( + ".tif", + ".tiff", + ".sdat", + ".sgrd", + ".rst", + ".rdc", + ".grd", + ".flt", + ".bil" ) - } + ) } - - +} diff --git a/R/conversion.R b/R/conversion.R index 33abd53..f9b52b7 100644 --- a/R/conversion.R +++ b/R/conversion.R @@ -15,29 +15,27 @@ #' wbw_slope(units = "d") |> #' wbw_to_radians() #' @export -wbw_to_radians <- - S7::new_generic( - name = "wbw_to_radians", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_to_radians, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - # Return Raster - WhiteboxRaster( - name = if (grepl("\\(degrees\\)", x@name)) { - sub("\\(degrees\\)", "(radians)", x@name) - } else { - x@name - }, - source = x@source$to_radians() - ) +wbw_to_radians <- S7::new_generic( + name = "wbw_to_radians", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_to_radians, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + # Return Raster + WhiteboxRaster( + name = if (grepl("\\(degrees\\)", x@name)) { + sub("\\(degrees\\)", "(radians)", x@name) + } else { + x@name + }, + source = x@source$to_radians() + ) +} #' Convert to degrees #' @keywords conversions @@ -56,27 +54,24 @@ S7::method(wbw_to_radians, WhiteboxRaster) <- #' wbw_slope(units = "r") |> #' wbw_to_degrees() #' @export -wbw_to_degrees <- - S7::new_generic( - name = "wbw_to_degrees", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_to_degrees, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - # Return Raster - WhiteboxRaster( - name = if (grepl("\\(radians\\)", x@name)) { - sub("\\(radians\\)", "(degrees)", x@name) - } else { - x@name - }, - source = x@source$to_degrees() - ) +wbw_to_degrees <- S7::new_generic( + name = "wbw_to_degrees", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) +S7::method(wbw_to_degrees, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + # Return Raster + WhiteboxRaster( + name = if (grepl("\\(radians\\)", x@name)) { + sub("\\(radians\\)", "(degrees)", x@name) + } else { + x@name + }, + source = x@source$to_degrees() + ) +} diff --git a/R/crs.R b/R/crs.R index 74d2286..d497e96 100644 --- a/R/crs.R +++ b/R/crs.R @@ -8,24 +8,22 @@ #' wbw_read_raster(f) |> #' wbw_ext() #' @export -wbw_ext <- - S7::new_generic( - name = "wbw_ext", - dispatch_args = "x", - fun = function(x) { - # Add some input validation - S7::S7_dispatch() - } - ) - -S7::method(wbw_ext, WhiteboxRaster) <- - function(x) { - # Checks - conf <- x@source$configs - WhiteboxExtent( - west = conf$west, - east = conf$east, - south = conf$south, - north = conf$north - ) +wbw_ext <- S7::new_generic( + name = "wbw_ext", + dispatch_args = "x", + fun = function(x) { + # Add some input validation + S7::S7_dispatch() } +) + +S7::method(wbw_ext, WhiteboxRaster) <- function(x) { + # Checks + conf <- x@source$configs + WhiteboxExtent( + west = conf$west, + east = conf$east, + south = conf$south, + north = conf$north + ) +} diff --git a/R/dimensions.R b/R/dimensions.R index 8639ab8..3007314 100644 --- a/R/dimensions.R +++ b/R/dimensions.R @@ -7,61 +7,55 @@ #' @return \code{integer} Number of cells in the raster #' #' @export -num_cells <- - S7::new_generic( - name = "num_cells", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(num_cells, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - x@source$num_cells() +num_cells <- S7::new_generic( + name = "num_cells", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(num_cells, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + x@source$num_cells() +} #' @rdname dimensions #' @keywords utils #' #' @export -wbw_rows <- - S7::new_generic( - name = "wbw_rows", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_rows, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - x@source$configs$rows +wbw_rows <- S7::new_generic( + name = "wbw_rows", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_rows, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + x@source$configs$rows +} #' @rdname dimensions #' @keywords utils #' #' @export -wbw_cols <- - S7::new_generic( - name = "wbw_cols", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_cols, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - x@source$configs$columns +wbw_cols <- S7::new_generic( + name = "wbw_cols", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_cols, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + x@source$configs$columns +} #' Get WhiteboxRaster resolution (x and y) #' @rdname resolution @@ -72,65 +66,58 @@ S7::method(wbw_cols, WhiteboxRaster) <- #' @return \code{double} Vector containing x and y resolution #' #' @export -wbw_res <- - S7::new_generic( - name = "wbw_res", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_res, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - c( - x@source$configs$resolution_x, - x@source$configs$resolution_y - ) +wbw_res <- S7::new_generic( + name = "wbw_res", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_res, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + c( + x@source$configs$resolution_x, + x@source$configs$resolution_y + ) +} #' @rdname resolution #' @keywords utils #' #' @export -wbw_xres <- - S7::new_generic( - name = "wbw_xres", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_xres, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - x@source$configs$resolution_x +wbw_xres <- S7::new_generic( + name = "wbw_xres", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_xres, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + x@source$configs$resolution_x +} #' @rdname resolution #' @keywords utils #' #' @export -wbw_yres <- - S7::new_generic( - name = "wbw_yres", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_yres, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) - x@source$configs$resolution_y +wbw_yres <- S7::new_generic( + name = "wbw_yres", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) +S7::method(wbw_yres, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) + x@source$configs$resolution_y +} #' Get WhiteboxRaster data type #' @rdname datatype @@ -142,19 +129,17 @@ S7::method(wbw_yres, WhiteboxRaster) <- #' @return \code{character} String representing the raster data type #' #' @export -wbw_data_type <- - S7::new_generic( - name = "wbw_data_type", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_data_type, WhiteboxRaster) <- - function(x) { - as.character(x@source$configs$data_type) +wbw_data_type <- S7::new_generic( + name = "wbw_data_type", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_data_type, WhiteboxRaster) <- function(x) { + as.character(x@source$configs$data_type) +} #' @rdname datatype #' @keywords utils @@ -163,31 +148,28 @@ S7::method(wbw_data_type, WhiteboxRaster) <- #' @eval rd_example("wbw_is_int") #' #' @export -wbw_is_int <- - S7::new_generic( - name = "wbw_is_int", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_is_int, WhiteboxRaster) <- - function(x) { - wbw_type <- - as.character(x@source$configs$data_type) - - any( - wbw_type == "RasterDataType.I32", - wbw_type == "RasterDataType.U32", - wbw_type == "RasterDataType.I64", - wbw_type == "RasterDataType.U64", - wbw_type == "RasterDataType.I16", - wbw_type == "RasterDataType.I8", - wbw_type == "RasterDataType.U16", - wbw_type == "RasterDataType.U8" - ) +wbw_is_int <- S7::new_generic( + name = "wbw_is_int", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(wbw_is_int, WhiteboxRaster) <- function(x) { + wbw_type <- as.character(x@source$configs$data_type) + + any( + wbw_type == "RasterDataType.I32", + wbw_type == "RasterDataType.U32", + wbw_type == "RasterDataType.I64", + wbw_type == "RasterDataType.U64", + wbw_type == "RasterDataType.I16", + wbw_type == "RasterDataType.I8", + wbw_type == "RasterDataType.U16", + wbw_type == "RasterDataType.U8" + ) +} #' @rdname datatype #' @keywords utils @@ -196,25 +178,22 @@ S7::method(wbw_is_int, WhiteboxRaster) <- #' @eval rd_example("wbw_is_float") #' #' @export -wbw_is_float <- - S7::new_generic( - name = "wbw_is_float", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) +wbw_is_float <- S7::new_generic( + name = "wbw_is_float", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() + } +) -S7::method(wbw_is_float, WhiteboxRaster) <- - function(x) { - wbw_type <- - as.character(x@source$configs$data_type) +S7::method(wbw_is_float, WhiteboxRaster) <- function(x) { + wbw_type <- as.character(x@source$configs$data_type) - any( - wbw_type == "RasterDataType.F32", - wbw_type == "RasterDataType.F64" - ) - } + any( + wbw_type == "RasterDataType.F32", + wbw_type == "RasterDataType.F64" + ) +} #' @rdname datatype #' @keywords utils @@ -223,23 +202,20 @@ S7::method(wbw_is_float, WhiteboxRaster) <- #' @eval rd_example("wbw_is_rgb") #' #' @export -wbw_is_rgb <- - S7::new_generic( - name = "wbw_is_rgb", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) +wbw_is_rgb <- S7::new_generic( + name = "wbw_is_rgb", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() + } +) -S7::method(wbw_is_rgb, WhiteboxRaster) <- - function(x) { - wbw_type <- - as.character(x@source$configs$data_type) +S7::method(wbw_is_rgb, WhiteboxRaster) <- function(x) { + wbw_type <- as.character(x@source$configs$data_type) - any( - wbw_type == "RasterDataType.RGB48", - wbw_type == "RasterDataType.RGB24", - wbw_type == "RasterDataType.RGBA32" - ) - } + any( + wbw_type == "RasterDataType.RGB48", + wbw_type == "RasterDataType.RGB24", + wbw_type == "RasterDataType.RGBA32" + ) +} diff --git a/R/geomorphometry.R b/R/geomorphometry.R index c7cb639..549c2e7 100644 --- a/R/geomorphometry.R +++ b/R/geomorphometry.R @@ -39,30 +39,26 @@ #' @seealso [wbw_to_degrees()], [wbw_to_radians()], [wbw_slope()] #' #' @export -wbw_aspect <- - S7::new_generic( - name = "wbw_aspect", - dispatch_args = "dem", - fun = function(dem, z_factor = 1.0) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_aspect, WhiteboxRaster) <- - function(dem, - z_factor = 1.0) { - # Checks - check_env(wbe) - checkmate::assert_double(z_factor, len = 1) - # Estimate aspect - out <- - wbe$aspect(dem = dem@source, z_factor = z_factor) - # Return Raster - WhiteboxRaster( - name = paste0("Aspect"), - source = out - ) +wbw_aspect <- S7::new_generic( + name = "wbw_aspect", + dispatch_args = "dem", + fun = function(dem, z_factor = 1.0) { + S7::S7_dispatch() } +) + +S7::method(wbw_aspect, WhiteboxRaster) <- function(dem, z_factor = 1.0) { + # Checks + check_env(wbe) + checkmate::assert_double(z_factor, len = 1) + # Estimate aspect + out <- wbe$aspect(dem = dem@source, z_factor = z_factor) + # Return Raster + WhiteboxRaster( + name = paste0("Aspect"), + source = out + ) +} #' Slope #' @rdname wbw_slope @@ -98,36 +94,34 @@ S7::method(wbw_aspect, WhiteboxRaster) <- #' @seealso [wbw_to_degrees()], [wbw_to_radians()], [wbw_aspect()] #' #' @export -wbw_slope <- - S7::new_generic( - name = "wbw_slope", - dispatch_args = "dem", - fun = function(dem, units = "degrees", z_factor = 1.0) { - S7::S7_dispatch() - } - ) - - -S7::method(wbw_slope, WhiteboxRaster) <- - function(dem, - units = "degrees", - z_factor = 1.0) { - # Checks - check_env(wbe) - units <- checkmate::matchArg( - units, - choices = c("radians", "degrees", "percent") - ) - checkmate::assert_double(z_factor, len = 1) - # Estimate slope - out <- - wbe$slope(dem = dem@source, units = units, z_factor = z_factor) - # Return Raster - WhiteboxRaster( - name = paste0("Slope (", units, ")"), - source = out - ) +wbw_slope <- S7::new_generic( + name = "wbw_slope", + dispatch_args = "dem", + fun = function(dem, units = "degrees", z_factor = 1.0) { + S7::S7_dispatch() } +) + +S7::method(wbw_slope, WhiteboxRaster) <- function( + dem, + units = "degrees", + z_factor = 1.0 +) { + # Checks + check_env(wbe) + units <- checkmate::matchArg( + units, + choices = c("radians", "degrees", "percent") + ) + checkmate::assert_double(z_factor, len = 1) + # Estimate slope + out <- wbe$slope(dem = dem@source, units = units, z_factor = z_factor) + # Return Raster + WhiteboxRaster( + name = paste0("Slope (", units, ")"), + source = out + ) +} #' Terrain Ruggedness Index (TRI) #' @rdname wbw_ruggedness_index @@ -158,25 +152,23 @@ S7::method(wbw_slope, WhiteboxRaster) <- #' @eval rd_example("wbw_ruggedness_index") #' #' @export -wbw_ruggedness_index <- - S7::new_generic( - name = "wbw_ruggedness_index", - dispatch_args = "dem", - fun = function(dem) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_ruggedness_index, WhiteboxRaster) <- - function(dem) { - # Checks - check_env(wbe) - out <- wbe$ruggedness_index(input = dem@source) - WhiteboxRaster( - name = paste0("TRI"), - source = out - ) +wbw_ruggedness_index <- S7::new_generic( + name = "wbw_ruggedness_index", + dispatch_args = "dem", + fun = function(dem) { + S7::S7_dispatch() } +) + +S7::method(wbw_ruggedness_index, WhiteboxRaster) <- function(dem) { + # Checks + check_env(wbe) + out <- wbe$ruggedness_index(input = dem@source) + WhiteboxRaster( + name = paste0("TRI"), + source = out + ) +} #' Fill Missing Data #' @keywords geomorphometry @@ -216,45 +208,46 @@ S7::method(wbw_ruggedness_index, WhiteboxRaster) <- #' @eval rd_example("wbw_fill_missing_data") #' #' @export -wbw_fill_missing_data <- - S7::new_generic( - name = "wbw_fill_missing_data", - dispatch_args = "x", - fun = function(x, - filter_size = 11L, - weight = 2, - exclude_edge_nodata = FALSE) { - S7::S7_dispatch() - } - ) +wbw_fill_missing_data <- S7::new_generic( + name = "wbw_fill_missing_data", + dispatch_args = "x", + fun = function( + x, + filter_size = 11L, + weight = 2, + exclude_edge_nodata = FALSE + ) { + S7::S7_dispatch() + } +) -S7::method(wbw_fill_missing_data, WhiteboxRaster) <- - function(x, - filter_size = 11L, - weight = 2, - exclude_edge_nodata = FALSE) { - # Checks - check_env(wbe) - filter_size <- - checkmate::asInteger( - filter_size, - lower = 0L, - len = 1L - ) - checkmate::assert_double(weight, len = 1) - checkmate::assert_logical(exclude_edge_nodata, len = 1) +S7::method(wbw_fill_missing_data, WhiteboxRaster) <- function( + x, + filter_size = 11L, + weight = 2, + exclude_edge_nodata = FALSE +) { + # Checks + check_env(wbe) + filter_size <- checkmate::asInteger( + filter_size, + lower = 0L, + len = 1L + ) + checkmate::assert_double(weight, len = 1) + checkmate::assert_logical(exclude_edge_nodata, len = 1) - # WBT - out <- wbe$fill_missing_data( - dem = x@source, - filter_size = filter_size, - weight = weight, - exclude_edge_nodata = exclude_edge_nodata - ) + # WBT + out <- wbe$fill_missing_data( + dem = x@source, + filter_size = filter_size, + weight = weight, + exclude_edge_nodata = exclude_edge_nodata + ) - # Return - WhiteboxRaster( - name = x@name, - source = out - ) - } + # Return + WhiteboxRaster( + name = x@name, + source = out + ) +} diff --git a/R/hillshade.R b/R/hillshade.R index a2282a5..9e27cc2 100644 --- a/R/hillshade.R +++ b/R/hillshade.R @@ -8,11 +8,11 @@ #' #' @details #' The hillshade value (HS) of a DEM grid cell is calculate as: -#' \deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times +#' \deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times #' [\frac{\sin(Alt)}{\tan(s)} - \cos(Alt) \times \sin(Az - a)]} -#' where \eqn{s} and \eqn{a} are the local slope gradient and aspect -#' (orientation) respectively and \eqn{Alt} and \eqn{Az} are the illumination -#' source altitude and azimuth respectively. Slope and aspect are calculated +#' where \eqn{s} and \eqn{a} are the local slope gradient and aspect +#' (orientation) respectively and \eqn{Alt} and \eqn{Az} are the illumination +#' source altitude and azimuth respectively. Slope and aspect are calculated #' using Horn's (1981) 3rd-order finate difference method. #' #' @eval rd_input_raster("dem") @@ -45,69 +45,66 @@ #' @eval rd_example("wbw_multidirectional_hillshade") #' #' @export -wbw_multidirectional_hillshade <- - S7::new_generic( - name = "wbw_multidirectional_hillshade", - dispatch_args = "dem", - fun = function(dem, - altitude = 30, - z_factor = 1, - full_360_mode = FALSE) { - S7::S7_dispatch() - } - ) +wbw_multidirectional_hillshade <- S7::new_generic( + name = "wbw_multidirectional_hillshade", + dispatch_args = "dem", + fun = function(dem, altitude = 30, z_factor = 1, full_360_mode = FALSE) { + S7::S7_dispatch() + } +) -S7::method(wbw_multidirectional_hillshade, WhiteboxRaster) <- - function(dem, - altitude = 30, - z_factor = 1, - full_360_mode = FALSE) { - # Checks - check_env(wbe) - checkmate::assert_double(altitude, len = 1, lower = 0, upper = 90) - checkmate::assert_double(z_factor, len = 1) - checkmate::assert_logical(full_360_mode, len = 1) +S7::method(wbw_multidirectional_hillshade, WhiteboxRaster) <- function( + dem, + altitude = 30, + z_factor = 1, + full_360_mode = FALSE +) { + # Checks + check_env(wbe) + checkmate::assert_double(altitude, len = 1, lower = 0, upper = 90) + checkmate::assert_double(z_factor, len = 1) + checkmate::assert_logical(full_360_mode, len = 1) - # WBT - out <- wbe$multidirectional_hillshade( - dem = dem@source, - altitude = altitude, - z_factor = z_factor, - full_360_mode = full_360_mode - ) + # WBT + out <- wbe$multidirectional_hillshade( + dem = dem@source, + altitude = altitude, + z_factor = z_factor, + full_360_mode = full_360_mode + ) - # Return - WhiteboxRaster( - name = paste0(dem@name, "(Hillshade)"), - source = out - ) - } + # Return + WhiteboxRaster( + name = paste0(dem@name, "(Hillshade)"), + source = out + ) +} #' Hillshade #' @keywords geomorphometry #' #' @description -#' This tool performs a hillshade operation (also called shaded relief) on an -#' input digital elevation model (DEM). +#' This tool performs a hillshade operation (also called shaded relief) on an +#' input digital elevation model (DEM). #' #' @details #' The hillshade value (HS) of a DEM grid cell is calculate as: -#' \deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times +#' \deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times #' [\frac{\sin(Alt)}{\tan(s)} - \cos(Alt) \times \sin(Az - a)]} -#' where \eqn{s} and \eqn{a} are the local slope gradient and aspect -#' (orientation) respectively and \eqn{Alt} and \eqn{Az} are the illumination -#' source altitude and azimuth respectively. Slope and aspect are calculated +#' where \eqn{s} and \eqn{a} are the local slope gradient and aspect +#' (orientation) respectively and \eqn{Alt} and \eqn{Az} are the illumination +#' source altitude and azimuth respectively. Slope and aspect are calculated #' using Horn's (1981) 3rd-order finate difference method. -#' -#' If the DEM is in the geographic coordinate system (latitude and longitude), +#' +#' If the DEM is in the geographic coordinate system (latitude and longitude), #' the following equation is used: #' \deqn{zfactor = \frac{1.0}{111320.0 \times \cos(midlat)}} -#' -#' where \eqn{midlat} is the latitude of the centre of the raster, +#' +#' where \eqn{midlat} is the latitude of the centre of the raster, #' in radians. #' #' @eval rd_input_raster("dem") -#' @param azimuth \code{double}, illumination source azimuth or +#' @param azimuth \code{double}, illumination source azimuth or #' sun direction (0 to 360 degrees) #' @param altitude \code{double}, the altitude of the illumination sources. #' i.e. the elevation of the sun above the horizon, measured as an angle from @@ -130,40 +127,37 @@ S7::method(wbw_multidirectional_hillshade, WhiteboxRaster) <- #' @eval rd_example("wbw_hillshade") #' #' @export -wbw_hillshade <- - S7::new_generic( - name = "wbw_hillshade", - dispatch_args = "dem", - fun = function(dem, - azimuth = 315, - altitude = 30, - z_factor = 1) { - S7::S7_dispatch() - } - ) +wbw_hillshade <- S7::new_generic( + name = "wbw_hillshade", + dispatch_args = "dem", + fun = function(dem, azimuth = 315, altitude = 30, z_factor = 1) { + S7::S7_dispatch() + } +) -S7::method(wbw_hillshade, WhiteboxRaster) <- - function(dem, - azimuth = 315, - altitude = 30, - z_factor = 1) { - # Checks - check_env(wbe) - checkmate::assert_double(azimuth, len = 1, lower = 0, upper = 360) - checkmate::assert_double(altitude, len = 1, lower = 0, upper = 90) - checkmate::assert_double(z_factor, len = 1) +S7::method(wbw_hillshade, WhiteboxRaster) <- function( + dem, + azimuth = 315, + altitude = 30, + z_factor = 1 +) { + # Checks + check_env(wbe) + checkmate::assert_double(azimuth, len = 1, lower = 0, upper = 360) + checkmate::assert_double(altitude, len = 1, lower = 0, upper = 90) + checkmate::assert_double(z_factor, len = 1) - # WBT - out <- wbe$hillshade( - dem = dem@source, - azimuth = azimuth, - altitude = altitude, - z_factor = z_factor - ) + # WBT + out <- wbe$hillshade( + dem = dem@source, + azimuth = azimuth, + altitude = altitude, + z_factor = z_factor + ) - # Return - WhiteboxRaster( - name = paste0(dem@name, "(Hillshade)"), - source = out - ) - } + # Return + WhiteboxRaster( + name = paste0(dem@name, "(Hillshade)"), + source = out + ) +} diff --git a/R/installation.R b/R/installation.R index 01b9bf0..1583c02 100644 --- a/R/installation.R +++ b/R/installation.R @@ -14,80 +14,82 @@ #' #' @details This function provides a basic wrapper around #' `reticulate::py_install()`, except it defaults to using the Python package -#' manager \code{pip} and virtual environment. It creates the \code{r-wbw} -#' virtual environment in the default location -#' (run `reticulate::virtualenv_root()` to find it) and installs the +#' manager \code{pip} and virtual environment. It creates the \code{r-wbw} +#' virtual environment in the default location +#' (run `reticulate::virtualenv_root()` to find it) and installs the #' required python packages. #' #' @return `NULL`, or `try-error` (invisibly) on R code execution error. #' #' @export -wbw_install <- - function(system = FALSE, force = FALSE, ...) { - args <- list(...) +wbw_install <- function(system = FALSE, force = FALSE, ...) { + args <- list(...) - venv_name <- "r-wbw" - venv_exists <- - try( - reticulate::virtualenv_exists(venv_name), - silent = TRUE - ) + venv_name <- "r-wbw" + venv_exists <- try( + reticulate::virtualenv_exists(venv_name), + silent = TRUE + ) - # Check if venv exists - if (venv_exists && !system) { - # Check if `whitebox-workflows` is installed - reticulate::use_virtualenv(venv_name) - wbw_version <- wbw_version() - } + # Check if venv exists + if (venv_exists && !system) { + # Check if `whitebox-workflows` is installed + reticulate::use_virtualenv(venv_name) + wbw_version <- wbw_version() + } - # Install `whitebox-workflows` - if (venv_exists && is.null(wbw_version) && !system) { - # venv exists but whitebox is not installed - # install it from https://pypi.org/project/whitebox-workflows/ - reticulate::use_virtualenv(virtualenv = venv_name) - reticulate::virtualenv_install( - packages = c("numpy", "whitebox-workflows==1.3.3"), - envname = venv_name - ) - .success_message(wbw_version()) - } else if (!venv_exists && !system) { - # nothing is installed, create venv and install deps - # from https://pypi.org/project/whitebox-workflows/ - reticulate::virtualenv_create( - envname = venv_name, - version = ">= 3.8" - ) - reticulate::use_virtualenv( - virtualenv = venv_name - ) - reticulate::virtualenv_install( - packages = c("numpy", "whitebox-workflows==1.3.3"), - envname = venv_name - ) - .success_message(wbw_version()) - cli::cli_alert_info( - c( - "Please, restart you R session" - ) + # Install `whitebox-workflows` + if (venv_exists && is.null(wbw_version) && !system) { + # venv exists but whitebox is not installed + # install it from https://pypi.org/project/whitebox-workflows/ + reticulate::use_virtualenv(virtualenv = venv_name) + reticulate::virtualenv_install( + packages = c("numpy", "whitebox-workflows==1.3.3"), + envname = venv_name + ) + .success_message(wbw_version()) + } else if (!venv_exists && !system) { + # nothing is installed, create venv and install deps + # from https://pypi.org/project/whitebox-workflows/ + reticulate::virtualenv_create( + envname = venv_name, + version = ">= 3.8" + ) + reticulate::use_virtualenv( + virtualenv = venv_name + ) + reticulate::virtualenv_install( + packages = c("numpy", "whitebox-workflows==1.3.3"), + envname = venv_name + ) + .success_message(wbw_version()) + cli::cli_alert_info( + c( + "Please, restart you R session" ) - } else if (venv_exists && !is.null(wbw_version) && !system) { - .success_message(wbw_version()) - } + ) + } else if (venv_exists && !is.null(wbw_version) && !system) { + .success_message(wbw_version()) + } - if (system) { - fp <- .find_python() - if (nchar(fp) > 0) { - return(invisible(system( - paste( - shQuote(fp), - "-m pip install --user", - ifelse(force, "-U --force", ""), - "whitebox-workflows==1.3.3 numpy" + if (system) { + fp <- .find_python() + if (nchar(fp) > 0) { + return( + invisible( + system( + paste( + shQuote(fp), + "-m pip install --user", + ifelse(force, "-U --force", ""), + "whitebox-workflows==1.3.3 numpy" + ) ) - ))) - } + ) + ) } } +} .success_message <- function(wbw_version) { cli::cli_alert_success( diff --git a/R/math.R b/R/math.R index b53d69f..6d1b705 100644 --- a/R/math.R +++ b/R/math.R @@ -2,12 +2,12 @@ #' @keywords math #' #' @description -#' Creates a random sample of grid cells from a raster. Uses the input -#' WhiteboxRaster to determine grid dimensions and georeference information for +#' Creates a random sample of grid cells from a raster. Uses the input +#' WhiteboxRaster to determine grid dimensions and georeference information for #' the output. #' #' The output grid will contain the specified number of non-zero grid cells, -#' randomly distributed throughout the raster. Each sampled cell will have a +#' randomly distributed throughout the raster. Each sampled cell will have a #' unique value from 1 to num_samples, with background cells set to zero. #' #' @details @@ -25,34 +25,32 @@ #' @eval rd_example("wbw_random_sample", c("num_samples = 100")) #' #' @export -wbw_random_sample <- - S7::new_generic( - name = "wbw_random_sample", - dispatch_args = "x", - fun = function(x, num_samples = 1000L) { - S7::S7_dispatch() - } - ) +wbw_random_sample <- S7::new_generic( + name = "wbw_random_sample", + dispatch_args = "x", + fun = function(x, num_samples = 1000L) { + S7::S7_dispatch() + } +) # !NB: # - set.seed() shouldn't work -S7::method(wbw_random_sample, WhiteboxRaster) <- - function(x, num_samples = 1000L) { - # Checks - check_env(wbe) - num_samples <- - checkmate::asInteger( - num_samples, - lower = 1L, - upper = x@source$num_cells(), - len = 1L - ) - out <- - wbe$random_sample(base_raster = x@source, num_samples = num_samples) - # Return Raster - WhiteboxRaster( - name = x@name, - source = out - ) - } - +S7::method(wbw_random_sample, WhiteboxRaster) <- function( + x, + num_samples = 1000L +) { + # Checks + check_env(wbe) + num_samples <- checkmate::asInteger( + num_samples, + lower = 1L, + upper = x@source$num_cells(), + len = 1L + ) + out <- wbe$random_sample(base_raster = x@source, num_samples = num_samples) + # Return Raster + WhiteboxRaster( + name = x@name, + source = out + ) +} diff --git a/R/matrix.R b/R/matrix.R index 578e0dc..0b98bfc 100644 --- a/R/matrix.R +++ b/R/matrix.R @@ -15,40 +15,38 @@ #' @eval rd_example("as_matrix", args = c("raw = TRUE")) #' #' @export -as_matrix <- - S7::new_generic( - name = "as_matrix", - dispatch_args = "x", - fun = function(x, raw = FALSE) { - S7::S7_dispatch() - } - ) - -S7::method(as_matrix, WhiteboxRaster) <- - function(x, raw = FALSE) { - checkmate::assert_environment(wbw_env) - m <- wbw_env$wbw_to_matrix(x@source, raw) - as.matrix(m) +as_matrix <- S7::new_generic( + name = "as_matrix", + dispatch_args = "x", + fun = function(x, raw = FALSE) { + S7::S7_dispatch() } +) + +S7::method(as_matrix, WhiteboxRaster) <- function(x, raw = FALSE) { + checkmate::assert_environment(wbw_env) + m <- wbw_env$wbw_to_matrix(x@source, raw) + as.matrix(m) +} #' Convert objects to vectors #' @name as_vector #' @rdname vector #' @keywords transform -#' +#' #' @description #' Converts various Whitebox objects to vectors: -#' * For [WhiteboxRaster]: converts raster values to a vector in row-major +#' * For [WhiteboxRaster]: converts raster values to a vector in row-major #' order #' * For [WhiteboxExtent]: converts extent boundaries to a named vector #' #' @param x Object to convert to vector. Can be: #' * A [WhiteboxRaster] object #' * A [WhiteboxExtent] object -#' @param raw logical. For [WhiteboxRaster] only: Should the raw data be -#' returned (`raw = TRUE`) or should NoData values be transformed +#' @param raw logical. For [WhiteboxRaster] only: Should the raw data be +#' returned (`raw = TRUE`) or should NoData values be transformed #' to `NA` (`raw = FALSE`)? -#' +#' #' @return A vector, with type depending on the input: #' * For [WhiteboxRaster]: vector containing raster values #' * For [WhiteboxExtent]: named vector containing extent values @@ -62,10 +60,10 @@ S7::method(as_matrix, WhiteboxRaster) <- #' @examples #' f <- system.file("extdata/dem.tif", package = "wbw") #' x <- wbw_read_raster(f) -#' +#' #' # Return WhiteboxRaster's data: #' head(as_vector(x)) -#' +#' #' # Return WhiteboxExtent's data: #' as_vector(wbw_ext(x)) #' diff --git a/R/plot.R b/R/plot.R index ac536b9..d672d55 100644 --- a/R/plot.R +++ b/R/plot.R @@ -5,10 +5,10 @@ NULL NULL #' Convert WhiteboxRaster to x-y coordinates -#' +#' #' This is an internal method used by the plotting system. #' It returns NULL coordinates to prevent default plotting behavior. -#' +#' #' @param x WhiteboxRaster object #' @param ... additional arguments (not used) #' @return A list with NULL x and y components @@ -26,41 +26,46 @@ NULL #' @param add Logical, whether to add to existing plot #' @param ... Additional arguments passed to plot #' @export -`plot.wbw::WhiteboxRaster` <- function(x, - col = grDevices::terrain.colors(100), - add = FALSE, - ...) { +`plot.wbw::WhiteboxRaster` <- function( + x, + col = grDevices::terrain.colors(100), + add = FALSE, + ... +) { # Get raster data as matrix z <- as_matrix(x, raw = FALSE) - + # Get extent conf <- x@source$configs ext <- c(conf$west, conf$east, conf$south, conf$north) - + # Create plot if (!add) { graphics::plot.new() graphics::plot.window(ext[1:2], ext[3:4], asp = 1) } - + # Plot raster graphics::rasterImage( grDevices::as.raster( matrix( - col[cut(z, breaks = length(col))], + col[cut(z, breaks = length(col))], nrow = nrow(z), ncol = ncol(z) ) ), - ext[1], ext[3], ext[2], ext[4] + ext[1], + ext[3], + ext[2], + ext[4] ) - + # Add axes and box if not adding to existing plot if (!add) { graphics::box() graphics::axis(1) graphics::axis(2) } - + invisible(x) } diff --git a/R/print.R b/R/print.R index cb61f50..4a0cf52 100644 --- a/R/print.R +++ b/R/print.R @@ -17,12 +17,16 @@ sprintf("dimensions : %d, %d (nrow, ncol)", conf$rows, conf$columns), sprintf( "resolution : %f, %f (x, y)", - conf$resolution_x, conf$resolution_y + conf$resolution_x, + conf$resolution_y ), sprintf("EPSG : %s (%s)", epsg, conf$xy_units), sprintf( "extent : %1.0f %1.0f %1.0f %1.0f", - conf$west, conf$east, conf$south, conf$north + conf$west, + conf$east, + conf$south, + conf$north ), sprintf("min value : %f", x@min), sprintf("max value : %f", x@max) diff --git a/R/summary.R b/R/summary.R index 8c792d9..a480386 100644 --- a/R/summary.R +++ b/R/summary.R @@ -10,7 +10,7 @@ NULL #' @rdname summarize #' @docType methods #' @keywords stats -#' +#' #' @description #' Computes summary statistics for cells in a [WhiteboxRaster] object. #' @@ -21,12 +21,11 @@ NULL #' @eval rd_wbw_link("raster_summary_stats") #' #' @export -`summary.wbw::WhiteboxRaster` <- - function(object, ...) { - cat( - wbe$raster_summary_stats(object@source) - ) - } +`summary.wbw::WhiteboxRaster` <- function(object, ...) { + cat( + wbe$raster_summary_stats(object@source) + ) +} #' @rdname summarize #' @docType methods @@ -61,7 +60,7 @@ NULL #' @docType methods #' #' @param x WhiteboxRaster object -#' @param na.rm logical indicating whether NA values should +#' @param na.rm logical indicating whether NA values should #' be stripped (not used) #' @param ... additional arguments (not used) #' @@ -95,21 +94,19 @@ NULL #' @eval rd_example("stdev") #' #' @export -stdev <- - S7::new_generic( - name = "stdev", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(stdev, WhiteboxRaster) <- - function(x) { - check_env(wbe) - stats <- wbe$raster_summary_stats(x@source) - extract_stat(stats, "standard deviation") +stdev <- S7::new_generic( + name = "stdev", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(stdev, WhiteboxRaster) <- function(x) { + check_env(wbe) + stats <- wbe$raster_summary_stats(x@source) + extract_stat(stats, "standard deviation") +} #' @rdname summarize #' @docType methods @@ -119,21 +116,19 @@ S7::method(stdev, WhiteboxRaster) <- #' @eval rd_example("variance") #' #' @export -variance <- - S7::new_generic( - name = "variance", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(variance, WhiteboxRaster) <- - function(x) { - check_env(wbe) - stats <- wbe$raster_summary_stats(x@source) - extract_stat(stats, "variance") +variance <- S7::new_generic( + name = "variance", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() } +) + +S7::method(variance, WhiteboxRaster) <- function(x) { + check_env(wbe) + stats <- wbe$raster_summary_stats(x@source) + extract_stat(stats, "variance") +} # Helper function to extract numeric value from a specific stat line extract_stat <- function(stats_text, pattern) { diff --git a/R/system.R b/R/system.R index b66cd6d..e9ffba0 100644 --- a/R/system.R +++ b/R/system.R @@ -26,19 +26,17 @@ #' system.time(wbw_slope(x)) #' } #' @export -wbw_max_procs <- - function(max_procs = -1) { - check_env(wbe) - max_procs <- checkmate::asInteger( - max_procs, - len = 1 - ) - checkmate::assert_true( - max_procs >= -1 && max_procs != 0 - ) - wbe$max_procs <- max_procs - } - +wbw_max_procs <- function(max_procs = -1) { + check_env(wbe) + max_procs <- checkmate::asInteger( + max_procs, + len = 1 + ) + checkmate::assert_true( + max_procs >= -1 && max_procs != 0 + ) + wbe$max_procs <- max_procs +} #' Download Sample Data #' @keywords system @@ -48,7 +46,7 @@ wbw_max_procs <- #' to test Whitebox Workflows for Python. #' #' @param data_set \code{character}, dataset name. See Details -#' @param path \code{character}, path to where download sample datasets. If +#' @param path \code{character}, path to where download sample datasets. If #' \code{NULL}, the currect working directory is used #' #' @details @@ -75,82 +73,80 @@ wbw_max_procs <- #' } #' @export #' @importFrom utils download.file unzip -wbw_download_sample_data <- - function(data_set = NULL, path = NULL) { - # Set Download Path if NULL - if (is.null(path)) { - path <- getwd() - } - checkmate::assert_directory( - path, - access = "w" +wbw_download_sample_data <- function(data_set = NULL, path = NULL) { + # Set Download Path if NULL + if (is.null(path)) { + path <- getwd() + } + checkmate::assert_directory( + path, + access = "w" + ) + + # Select Dataset + data_set <- checkmate::matchArg( + data_set, + choices = c( + "Guelph_landsat", + "Grand_Junction", + "GTA_lidar", + "jay_brook", + "Jay_State_Forest", + "Kitchener_lidar", + "London_air_photo", + "mill_brook", + "peterborough_drumlins", + "Southern_Ontario_roads", + "StElisAk" ) + ) - # Select Dataset - data_set <- - checkmate::matchArg( - data_set, - choices = c( - "Guelph_landsat", - "Grand_Junction", - "GTA_lidar", - "jay_brook", - "Jay_State_Forest", - "Kitchener_lidar", - "London_air_photo", - "mill_brook", - "peterborough_drumlins", - "Southern_Ontario_roads", - "StElisAk" - ) - ) + # Create sub-directory if it doesn't exist + download_path <- file.path(path, data_set) + if (!dir.exists(download_path)) { + dir.create(download_path) + } - # Create sub-directory if it doesn't exist - download_path <- file.path(path, data_set) - if (!dir.exists(download_path)) { - dir.create(download_path) - } + # Download Data + base_url <- "https://www.whiteboxgeo.com/sample_data/" + data_url <- paste0(base_url, data_set, ".zip") + download.file( + data_url, + destfile = file.path(download_path, paste0(data_set, ".zip")) + ) - # Download Data - base_url <- "https://www.whiteboxgeo.com/sample_data/" - data_url <- paste0(base_url, data_set, ".zip") - download.file( - data_url, - destfile = file.path(download_path, paste0(data_set, ".zip")) - ) + # Unzip Data + temp_dir <- file.path(download_path, "temp_extract") + dir.create(temp_dir) - # Unzip Data - temp_dir <- file.path(download_path, "temp_extract") - dir.create(temp_dir) - - unzip( - file.path(download_path, paste0(data_set, ".zip")), - exdir = temp_dir - ) - - # Check if data_set folder exists inside the extracted contents - dataset_folder <- file.path(temp_dir, data_set) - if (dir.exists(dataset_folder)) { - # If dataset folder exists, move its contents to download_path - files_to_move <- list.files(dataset_folder, full.names = TRUE) - file.copy(files_to_move, download_path, recursive = TRUE) - } else { - # If no specific dataset folder, move all contents except __MACOSX - all_contents <- list.files(temp_dir, full.names = TRUE) - files_to_move <- all_contents[!grepl("__MACOSX", all_contents)] - file.copy(files_to_move, download_path, recursive = TRUE) - } - - # Clean up - unlink(temp_dir, recursive = TRUE) - unlink(file.path(download_path, paste0(data_set, ".zip"))) + unzip( + file.path(download_path, paste0(data_set, ".zip")), + exdir = temp_dir + ) - # Return download path - cli::cli_alert_success( - c( - "Sample dataset '{.val {data_set}}' ", - "downloaded to: {.file {download_path}}" - ) - ) - return(download_path) + # Check if data_set folder exists inside the extracted contents + dataset_folder <- file.path(temp_dir, data_set) + if (dir.exists(dataset_folder)) { + # If dataset folder exists, move its contents to download_path + files_to_move <- list.files(dataset_folder, full.names = TRUE) + file.copy(files_to_move, download_path, recursive = TRUE) + } else { + # If no specific dataset folder, move all contents except __MACOSX + all_contents <- list.files(temp_dir, full.names = TRUE) + files_to_move <- all_contents[!grepl("__MACOSX", all_contents)] + file.copy(files_to_move, download_path, recursive = TRUE) } + + # Clean up + unlink(temp_dir, recursive = TRUE) + unlink(file.path(download_path, paste0(data_set, ".zip"))) + + # Return download path + cli::cli_alert_success( + c( + "Sample dataset '{.val {data_set}}' ", + "downloaded to: {.file {download_path}}" + ) + ) + return(download_path) +} diff --git a/R/terra.R b/R/terra.R index 88b9236..b6b4925 100644 --- a/R/terra.R +++ b/R/terra.R @@ -17,64 +17,60 @@ #' as_rast() #' } #' @export -as_rast <- - S7::new_generic( - name = "as_rast", - dispatch_args = "x", - fun = function(x) { - S7::S7_dispatch() - } - ) - -S7::method(as_rast, WhiteboxRaster) <- - function(x) { - # Checks - check_env(wbe) +as_rast <- S7::new_generic( + name = "as_rast", + dispatch_args = "x", + fun = function(x) { + S7::S7_dispatch() + } +) - # Prepare data - v <- as_vector(x) - wbw_nodata <- x@source$configs$nodata - # TODO: - # Depending on the x@source$configs$data_type, - # Use either NA_integer_ or NA_real_ - v[v == wbw_nodata] <- NA +S7::method(as_rast, WhiteboxRaster) <- function(x) { + # Checks + check_env(wbe) - # Prepare CRS and Extent - ext <- - c( - # Note the differences in east and south between reading by - # GDAL (i.e. terra) and WhiteboxTools - x@source$configs$west, - x@source$configs$east + wbw_xres(x), - x@source$configs$south - wbw_yres(x), - x@source$configs$north - ) - crs <- if (x@source$configs$epsg_code == 0) { - x@source$configs$coordinate_ref_system_wkt - } else { - terra::crs(paste0("epsg:", x@source$configs$epsg_code)) - } + # Prepare data + v <- as_vector(x) + wbw_nodata <- x@source$configs$nodata + # TODO: + # Depending on the x@source$configs$data_type, + # Use either NA_integer_ or NA_real_ + v[v == wbw_nodata] <- NA - # Convert - new_rast <- - terra::rast( - vals = v, - nlyrs = 1L, - crs = crs, - extent = ext, - resolution = wbw_res(x), - names = x@name - ) + # Prepare CRS and Extent + ext <- c( + # Note the differences in east and south between reading by + # GDAL (i.e. terra) and WhiteboxTools + x@source$configs$west, + x@source$configs$east + wbw_xres(x), + x@source$configs$south - wbw_yres(x), + x@source$configs$north + ) + crs <- if (x@source$configs$epsg_code == 0) { + x@source$configs$coordinate_ref_system_wkt + } else { + terra::crs(paste0("epsg:", x@source$configs$epsg_code)) + } - # Convert to integer if necessary - if (wbw_is_int(x)) { - new_rast <- terra::as.int(new_rast) - } + # Convert + new_rast <- terra::rast( + vals = v, + nlyrs = 1L, + crs = crs, + extent = ext, + resolution = wbw_res(x), + names = x@name + ) - # Return - new_rast + # Convert to integer if necessary + if (wbw_is_int(x)) { + new_rast <- terra::as.int(new_rast) } + # Return + new_rast +} + #' Convert SpatRaster to WhiteboxRaster #' @keywords terra #' @@ -94,74 +90,74 @@ S7::method(as_rast, WhiteboxRaster) <- #' as_wbw_raster() #' } #' @export -as_wbw_raster <- - function(x) { - # Checks - checkmate::assert_class(x, "SpatRaster") - checkmate::assert_class( - wbw, - classes = c( - "python.builtin.module", - "python.builtin.object" - ) - ) - checkmate::assert_true( - terra::nlyr(x) == 1 +as_wbw_raster <- function(x) { + # Checks + checkmate::assert_class(x, "SpatRaster") + checkmate::assert_class( + wbw, + classes = c( + "python.builtin.module", + "python.builtin.object" ) + ) + checkmate::assert_true( + terra::nlyr(x) == 1 + ) - # SpatRaster information - na_terra <- terra::NAflag(x) - nodata_value <- if (is.nan(na_terra)) { - -9999 - } else { - na_terra - } - res_terra <- terra::res(x) - name_terra <- names(x) - type_terra <- any(c( + # SpatRaster information + na_terra <- terra::NAflag(x) + nodata_value <- if (is.nan(na_terra)) { + -9999 + } else { + na_terra + } + res_terra <- terra::res(x) + name_terra <- names(x) + type_terra <- any( + c( terra::is.int(x), terra::is.bool(x), terra::is.factor(x) - )) - ext_terra <- terra::ext(x) - data_terra <- as.matrix(x, wide = TRUE) - data_terra[is.na(data_terra)] <- nodata_value + ) + ) + ext_terra <- terra::ext(x) + data_terra <- as.matrix(x, wide = TRUE) + data_terra[is.na(data_terra)] <- nodata_value - # Create new RasterConfigs - new_config <- wbw$RasterConfigs() - new_config$title <- name_terra + # Create new RasterConfigs + new_config <- wbw$RasterConfigs() + new_config$title <- name_terra - # Dimensions - new_config$bands <- as.integer(terra::nlyr(x)) - new_config$columns <- as.integer(terra::ncol(x)) - new_config$rows <- as.integer(terra::nrow(x)) - new_config$west <- as.double(ext_terra[1]) - ## Note the differences in east and south between reading by - ## GDAL (i.e. terra) and WhiteboxTools - new_config$east <- as.double(ext_terra[2]) - res_terra[1] - new_config$south <- as.double(ext_terra[3]) + res_terra[2] - new_config$north <- as.double(ext_terra[4]) + # Dimensions + new_config$bands <- as.integer(terra::nlyr(x)) + new_config$columns <- as.integer(terra::ncol(x)) + new_config$rows <- as.integer(terra::nrow(x)) + new_config$west <- as.double(ext_terra[1]) + ## Note the differences in east and south between reading by + ## GDAL (i.e. terra) and WhiteboxTools + new_config$east <- as.double(ext_terra[2]) - res_terra[1] + new_config$south <- as.double(ext_terra[3]) + res_terra[2] + new_config$north <- as.double(ext_terra[4]) - # CRS - new_config$coordinate_ref_system_wkt <- terra::crs(x) - new_config$resolution_x <- res_terra[1] - new_config$resolution_y <- res_terra[2] + # CRS + new_config$coordinate_ref_system_wkt <- terra::crs(x) + new_config$resolution_x <- res_terra[1] + new_config$resolution_y <- res_terra[2] - # Data type - new_config$nodata <- nodata_value - new_config$data_type <- - if (type_terra) { - wbw$RasterDataType$I16 - } else { - wbw$RasterDataType$F32 - } + # Data type + new_config$nodata <- nodata_value + new_config$data_type <- if (type_terra) { + wbw$RasterDataType$I16 + } else { + wbw$RasterDataType$F32 + } - # Create WhiteboxRaster - new_raster <- wbe$new_raster(new_config) - wbw_env$matrix_to_wbw(data_terra, new_raster) + # Create WhiteboxRaster + new_raster <- wbe$new_raster(new_config) + wbw_env$matrix_to_wbw(data_terra, new_raster) - WhiteboxRaster( - name = name_terra, - source = new_raster - ) - } + WhiteboxRaster( + name = name_terra, + source = new_raster + ) +} diff --git a/R/utils_documentation.R b/R/utils_documentation.R index a9e327f..33a9538 100644 --- a/R/utils_documentation.R +++ b/R/utils_documentation.R @@ -4,17 +4,16 @@ #' Links to the Whitebox Workflows for Python manual #' #' @keywords internal -rd_wbw_link <- - function(fun_name) { - checkmate::assert_character(fun_name, min.chars = 1L) - paste0( - "@references For more information, see ", - "" - ) - } +rd_wbw_link <- function(fun_name) { + checkmate::assert_character(fun_name, min.chars = 1L) + paste0( + "@references For more information, see ", + "" + ) +} #' Create input parameter tag #' @@ -22,37 +21,39 @@ rd_wbw_link <- #' Description of input [WhiteboxRaster] object #' #' @keywords internal -rd_input_raster <- - function(param) { - checkmate::assert_character(param, min.chars = 1L) - paste0( - "@param ", param, - " Raster object of class [WhiteboxRaster]. ", - "See [wbw_read_raster()] for more details." - ) - } +rd_input_raster <- function(param) { + checkmate::assert_character(param, min.chars = 1L) + paste0( + "@param ", + param, + " Raster object of class [WhiteboxRaster]. ", + "See [wbw_read_raster()] for more details." + ) +} #' Create basic example #' #' @keywords internal -rd_example <- - function(foo, args = NULL) { - checkmate::assert_character(foo, min.chars = 1L) - checkmate::assert_vector(args, null.ok = TRUE) - paste( - "@examples", - # "\\dontrun{", - 'f <- system.file("extdata/dem.tif", package = "wbw")', - "wbw_read_raster(f) |>", - ifelse( - is.null(args), - paste0(" ", foo, "()"), - paste0( - " ", foo, "(", - paste(args, collapse = ", "), ")" - ) - ), - # "}", - sep = "\n" - ) - } \ No newline at end of file +rd_example <- function(foo, args = NULL) { + checkmate::assert_character(foo, min.chars = 1L) + checkmate::assert_vector(args, null.ok = TRUE) + paste( + "@examples", + # "\\dontrun{", + 'f <- system.file("extdata/dem.tif", package = "wbw")', + "wbw_read_raster(f) |>", + ifelse( + is.null(args), + paste0(" ", foo, "()"), + paste0( + " ", + foo, + "(", + paste(args, collapse = ", "), + ")" + ) + ), + # "}", + sep = "\n" + ) +} diff --git a/R/write.R b/R/write.R index 00b68c4..850a265 100644 --- a/R/write.R +++ b/R/write.R @@ -3,7 +3,7 @@ #' @keywords io #' #' @description -#' Writes an in-memory WhiteboxRaster object to a file in a supported raster +#' Writes an in-memory WhiteboxRaster object to a file in a supported raster #' format. #' #' @eval rd_wbw_link("write_raster") @@ -22,26 +22,28 @@ #' - ESRI Binary (*.flt) #' - ESRI BIL (*.bil) #' -#' The tool can read GeoTIFFs compressed using PackBits, DEFLATE, or LZW +#' The tool can read GeoTIFFs compressed using PackBits, DEFLATE, or LZW #' methods. #' #' When writing GeoTIFFs, use `compress=TRUE` to enable DEFLATE compression. #' #' @export -wbw_write_raster <- - S7::new_generic( - name = "wbw_write_raster", - dispatch_args = "x", - fun = function(x, file_name, compress = TRUE) { - S7::S7_dispatch() - } - ) - -S7::method(wbw_write_raster, WhiteboxRaster) <- - function(x, file_name, compress = TRUE) { - # Checks - check_env(wbe) - checkmate::assert_logical(compress, len = 1) - # Write - wbe$write_raster(x@source, file_name = file_name, compress = compress) +wbw_write_raster <- S7::new_generic( + name = "wbw_write_raster", + dispatch_args = "x", + fun = function(x, file_name, compress = TRUE) { + S7::S7_dispatch() } +) + +S7::method(wbw_write_raster, WhiteboxRaster) <- function( + x, + file_name, + compress = TRUE +) { + # Checks + check_env(wbe) + checkmate::assert_logical(compress, len = 1) + # Write + wbe$write_raster(x@source, file_name = file_name, compress = compress) +} diff --git a/R/zzz.R b/R/zzz.R index a3d6593..d1a7c47 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -2,7 +2,6 @@ # https://github.com/JosiahParry/pyfns as an examples. # Thanks guys! - wbw <- NULL wbe <- NULL @@ -10,21 +9,19 @@ wbe <- NULL #' @return character. Version Number. #' @export #' @importFrom reticulate py_eval -wbw_version <- - function() { - try( - reticulate::py_run_string("from importlib.metadata import version"), - silent = TRUE - ) - version <- - try( - reticulate::py_eval("version('whitebox_workflows')"), - silent = TRUE - ) - if (!inherits(version, "try-error")) { - version - } +wbw_version <- function() { + try( + reticulate::py_run_string("from importlib.metadata import version"), + silent = TRUE + ) + version <- try( + reticulate::py_eval("version('whitebox_workflows')"), + silent = TRUE + ) + if (!inherits(version, "try-error")) { + version } +} #' @importFrom reticulate import #' @importFrom reticulate py_run_string @@ -33,11 +30,10 @@ wbw_version <- try( { reticulate::use_virtualenv(virtualenv = "r-wbw") - wbw <<- - reticulate::import( - "whitebox_workflows", - delay_load = TRUE - ) + wbw <<- reticulate::import( + "whitebox_workflows", + delay_load = TRUE + ) }, silent = TRUE ) @@ -103,11 +99,13 @@ wbw_version <- cli::cli_alert_warning( "Library {.code whitebox-workflows} is required but not found." ) - choice <- utils::menu(c( - "Install dependencies in a virtual environment (recommended)", - "Install dependencies system-wide", - "Do nothing" - )) + choice <- utils::menu( + c( + "Install dependencies in a virtual environment (recommended)", + "Install dependencies system-wide", + "Do nothing" + ) + ) if (choice == 1) { cli::cli_alert_info( @@ -167,22 +165,28 @@ wbw_version <- } } - #' @importFrom utils packageVersion .onAttach <- function(libname, pkgname) { wbwv <- wbw_version() - suppress <- - !grepl("suppressed", Sys.getenv("wbw.message"), ignore.case = TRUE) + suppress <- !grepl( + "suppressed", + Sys.getenv("wbw.message"), + ignore.case = TRUE + ) if (is.null(wbwv) && suppress && interactive()) { - cli::cli_alert_warning(c( - "Python package `whitebox-workflows` cannot be found.", - "Run {.code wbw::wbw_install()} and reload R session." - )) + cli::cli_alert_warning( + c( + "Python package `whitebox-workflows` cannot be found.", + "Run {.code wbw::wbw_install()} and reload R session." + ) + ) } else if (!is.null(wbwv) && suppress) { - cli::cli_alert_success(c( - "wbw v{utils::packageVersion('wbw')} -- using whitebox-workflows v{wbwv}" - )) + cli::cli_alert_success( + c( + "wbw v{utils::packageVersion('wbw')} -- using whitebox-workflows v{wbwv}" + ) + ) } } diff --git a/man/wbw_hillshade.Rd b/man/wbw_hillshade.Rd index 7637b0e..46cc5ae 100644 --- a/man/wbw_hillshade.Rd +++ b/man/wbw_hillshade.Rd @@ -30,7 +30,7 @@ input digital elevation model (DEM). } \details{ The hillshade value (HS) of a DEM grid cell is calculate as: -\deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times +\deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times [\frac{\sin(Alt)}{\tan(s)} - \cos(Alt) \times \sin(Az - a)]} where \eqn{s} and \eqn{a} are the local slope gradient and aspect (orientation) respectively and \eqn{Alt} and \eqn{Az} are the illumination diff --git a/man/wbw_multidirectional_hillshade.Rd b/man/wbw_multidirectional_hillshade.Rd index 4900b9e..e7ad1c4 100644 --- a/man/wbw_multidirectional_hillshade.Rd +++ b/man/wbw_multidirectional_hillshade.Rd @@ -43,7 +43,7 @@ illumination. } \details{ The hillshade value (HS) of a DEM grid cell is calculate as: -\deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times +\deqn{HS = \frac{\tan(s)}{\sqrt{1 - \tan(s)^2}} \times [\frac{\sin(Alt)}{\tan(s)} - \cos(Alt) \times \sin(Az - a)]} where \eqn{s} and \eqn{a} are the local slope gradient and aspect (orientation) respectively and \eqn{Alt} and \eqn{Az} are the illumination diff --git a/tests/tinytest/setup.R b/tests/tinytest/setup.R index bfb5f99..e38fcf6 100644 --- a/tests/tinytest/setup.R +++ b/tests/tinytest/setup.R @@ -7,13 +7,13 @@ x <- wbw_read_raster(raster_path) # Path to terra's files if (requireNamespace("terra", quietly = TRUE)) { - library(terra) - f <- system.file("ex/elev.tif", package = "terra") -} + library(terra) + f <- system.file("ex/elev.tif", package = "terra") +} # Helper functions skip_if_not_installed <- function(pkg) { - if (!requireNamespace(pkg, quietly = TRUE)) { - exit_file("Package", pkg, "not available") - } + if (!requireNamespace(pkg, quietly = TRUE)) { + exit_file("Package", pkg, "not available") + } } diff --git a/tests/tinytest/test_checks.R b/tests/tinytest/test_checks.R index 91ac0ed..b83fef4 100644 --- a/tests/tinytest/test_checks.R +++ b/tests/tinytest/test_checks.R @@ -6,12 +6,12 @@ expect_error(wbw:::check_package("nonexistentpackage123")) # Environment checks mock_env <- structure( - list(), - class = c( - "whitebox_workflows.WbEnvironment", - "python.builtin.WbEnvironmentBase", - "python.builtin.object" - ) + list(), + class = c( + "whitebox_workflows.WbEnvironment", + "python.builtin.WbEnvironmentBase", + "python.builtin.object" + ) ) expect_silent(wbw:::check_env(mock_env)) diff --git a/tests/tinytest/test_conversions.R b/tests/tinytest/test_conversions.R index c5c210b..5db4d72 100644 --- a/tests/tinytest/test_conversions.R +++ b/tests/tinytest/test_conversions.R @@ -8,4 +8,4 @@ rad_to_deg <- wbw_to_degrees(slope_rad) expect_inherits(deg_to_rad, c("wbw::WhiteboxRaster", "S7_object")) expect_inherits(rad_to_deg, c("wbw::WhiteboxRaster", "S7_object")) expect_equal(mean(slope_rad), mean(deg_to_rad)) -expect_equal(mean(slope_deg), mean(rad_to_deg)) +expect_equal(mean(slope_deg), mean(rad_to_deg)) diff --git a/tests/tinytest/test_crs.R b/tests/tinytest/test_crs.R index 37acbf5..f372e1e 100644 --- a/tests/tinytest/test_crs.R +++ b/tests/tinytest/test_crs.R @@ -12,4 +12,4 @@ expect_identical(ext@north, x@source$configs$north) # Test error cases expect_error(wbw_ext("x")) -expect_error(wbw_ext(NULL)) \ No newline at end of file +expect_error(wbw_ext(NULL)) diff --git a/tests/tinytest/test_curvature.R b/tests/tinytest/test_curvature.R index b4d4660..669cbed 100644 --- a/tests/tinytest/test_curvature.R +++ b/tests/tinytest/test_curvature.R @@ -2,24 +2,24 @@ source("setup.R") # Test successful filter returns expect_inherits( - wbw_gaussian_curvature(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_gaussian_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_maximal_curvature(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_maximal_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_minimal_curvature(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_minimal_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_mean_curvature(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_mean_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_profile_curvature(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_profile_curvature(x), + c("wbw::WhiteboxRaster", "S7_object") ) # Test curvature alterations @@ -30,62 +30,62 @@ expect_inherits( true_median <- median(x) expect_true( - wbw_gaussian_curvature(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_gaussian_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_gaussian_curvature(x, log_transform = TRUE) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_gaussian_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_maximal_curvature(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_maximal_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_maximal_curvature(x, log_transform = TRUE) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_maximal_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_minimal_curvature(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_minimal_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_minimal_curvature(x, log_transform = TRUE) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_minimal_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_mean_curvature(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_mean_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_mean_curvature(x, log_transform = TRUE) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_mean_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_profile_curvature(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_profile_curvature(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_profile_curvature(x, log_transform = TRUE) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_profile_curvature(x, log_transform = TRUE) |> + median() |> + all.equal(true_median) |> + is.character() ) diff --git a/tests/tinytest/test_filter.R b/tests/tinytest/test_filter.R index c39ab7c..8ff4389 100644 --- a/tests/tinytest/test_filter.R +++ b/tests/tinytest/test_filter.R @@ -2,68 +2,68 @@ source("setup.R") # Test successful filter returns expect_inherits( - wbw_adaptive_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_adaptive_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_bilateral_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_bilateral_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_conservative_smoothing_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_conservative_smoothing_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_gaussian_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_gaussian_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_high_pass_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_high_pass_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_high_pass_median_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_high_pass_median_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_majority_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_majority_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_maximum_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_maximum_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_mean_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_mean_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_median_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_median_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_minimum_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_minimum_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_olympic_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_olympic_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_percentile_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_percentile_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_range_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_range_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_total_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_total_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) expect_inherits( - wbw_standard_deviation_filter(x), - c("wbw::WhiteboxRaster", "S7_object") + wbw_standard_deviation_filter(x), + c("wbw::WhiteboxRaster", "S7_object") ) # Test filter alterations @@ -74,105 +74,105 @@ expect_inherits( true_median <- median(x) expect_true( - wbw_adaptive_filter( - x, - filter_size_x = 51, - filter_size_y = 51 - ) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_adaptive_filter( + x, + filter_size_x = 51, + filter_size_y = 51 + ) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_bilateral_filter( - x, - sigma_dist = 3 - ) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_bilateral_filter( + x, + sigma_dist = 3 + ) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_conservative_smoothing_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_conservative_smoothing_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_gaussian_filter(x, sigma = 1.5) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_gaussian_filter(x, sigma = 1.5) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_high_pass_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_high_pass_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_high_pass_median_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_high_pass_median_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_majority_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_majority_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_maximum_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_maximum_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_mean_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_mean_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_median_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_median_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_minimum_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_minimum_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_olympic_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_olympic_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_percentile_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_percentile_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_range_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_range_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_total_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_total_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) expect_true( - wbw_standard_deviation_filter(x) |> - median() |> - all.equal(true_median) |> - is.character() + wbw_standard_deviation_filter(x) |> + median() |> + all.equal(true_median) |> + is.character() ) diff --git a/tests/tinytest/test_geomorphometry.R b/tests/tinytest/test_geomorphometry.R index 2d4e7d6..f00832c 100644 --- a/tests/tinytest/test_geomorphometry.R +++ b/tests/tinytest/test_geomorphometry.R @@ -29,14 +29,17 @@ expect_inherits(wbw_aspect(x), c("wbw::WhiteboxRaster", "S7_object")) expect_inherits(wbw_slope(x), c("wbw::WhiteboxRaster", "S7_object")) expect_inherits(wbw_ruggedness_index(x), c("wbw::WhiteboxRaster", "S7_object")) expect_inherits(wbw_fill_missing_data(x), c("wbw::WhiteboxRaster", "S7_object")) -expect_inherits(wbw_multidirectional_hillshade(x), c("wbw::WhiteboxRaster", "S7_object")) +expect_inherits( + wbw_multidirectional_hillshade(x), + c("wbw::WhiteboxRaster", "S7_object") +) expect_inherits(wbw_hillshade(x), c("wbw::WhiteboxRaster", "S7_object")) # Test sample data download and fill missing data temp_dir <- tempdir() test_path <- wbw_download_sample_data( - data_set = "Grand_Junction", - path = temp_dir + data_set = "Grand_Junction", + path = temp_dir ) expect_true(dir.exists(test_path)) @@ -55,4 +58,4 @@ m_filled <- as_matrix(dem_filled) expect_true(sum(is.na(m_filled)) <= sum(is.na(m))) # Clean up -unlink(file.path(temp_dir, "Grand_Junction"), recursive = TRUE) +unlink(file.path(temp_dir, "Grand_Junction"), recursive = TRUE) diff --git a/tests/tinytest/test_io.R b/tests/tinytest/test_io.R index f946254..286d19c 100644 --- a/tests/tinytest/test_io.R +++ b/tests/tinytest/test_io.R @@ -2,20 +2,22 @@ source("setup.R") # Helper function create_temp_file <- function(ext) { - tmp <- tempfile(fileext = ext) - file.create(tmp) - return(tmp) + tmp <- tempfile(fileext = ext) + file.create(tmp) + return(tmp) } # Test wbw_read_raster -expect_inherits(wbw_read_raster(raster_path), c("wbw::WhiteboxRaster", "S7_object")) +expect_inherits( + wbw_read_raster(raster_path), + c("wbw::WhiteboxRaster", "S7_object") +) expect_error(wbw_read_raster("nonexistent.tif")) tmp_txt <- create_temp_file(".txt") on.exit(unlink(tmp_txt)) expect_error(wbw_read_raster(tmp_txt)) - tmp_shp <- create_temp_file(".shp") on.exit(unlink(tmp_shp), add = TRUE) expect_error(wbw_read_vector("nonexistent.shp")) @@ -29,12 +31,15 @@ tmp_tif_c <- tempfile(fileext = ".tif") tmp_tiff_c <- tempfile(fileext = ".tiff") tmp_tif <- tempfile(fileext = ".tif") tmp_tiff <- tempfile(fileext = ".tiff") -on.exit({ - unlink(tmp_tif_c) - unlink(tmp_tiff_c) - unlink(tmp_tif) - unlink(tmp_tiff) -}, add = TRUE) +on.exit( + { + unlink(tmp_tif_c) + unlink(tmp_tiff_c) + unlink(tmp_tif) + unlink(tmp_tiff) + }, + add = TRUE +) wbw_write_raster(x, file_name = tmp_tif_c, compress = TRUE) wbw_write_raster(x, file_name = tmp_tiff_c, compress = TRUE) @@ -45,13 +50,22 @@ expect_true(file.size(tmp_tif_c) < file.size(tmp_tif)) expect_true(file.size(tmp_tiff_c) < file.size(tmp_tiff)) # Test different raster formats -formats <- c(".tif", ".tiff", ".sgrd", ".sdat", ".rst", - ".rdc", ".bil", ".flt", ".grd") +formats <- c( + ".tif", + ".tiff", + ".sgrd", + ".sdat", + ".rst", + ".rdc", + ".bil", + ".flt", + ".grd" +) temp_files <- vapply(formats, create_temp_file, character(1)) on.exit(unlink(temp_files), add = TRUE) for (file in temp_files) { - wbw_write_raster(x, file_name = file) - expect_true(file.exists(file)) - expect_inherits(wbw_read_raster(file), c("wbw::WhiteboxRaster", "S7_object")) -} \ No newline at end of file + wbw_write_raster(x, file_name = file) + expect_true(file.exists(file)) + expect_inherits(wbw_read_raster(file), c("wbw::WhiteboxRaster", "S7_object")) +} diff --git a/tests/tinytest/test_math.R b/tests/tinytest/test_math.R index 6243b19..9c93328 100644 --- a/tests/tinytest/test_math.R +++ b/tests/tinytest/test_math.R @@ -2,9 +2,12 @@ source("setup.R") # Test random sample generation expect_inherits(wbw_random_sample(x), c("wbw::WhiteboxRaster", "S7_object")) -expect_inherits(wbw_random_sample(x, num_samples = 1), c("wbw::WhiteboxRaster", "S7_object")) +expect_inherits( + wbw_random_sample(x, num_samples = 1), + c("wbw::WhiteboxRaster", "S7_object") +) # Test error conditions expect_error(wbw_random_sample(x, num_samples = -1)) expect_error(wbw_random_sample(x, num_samples = runif(1))) -expect_error(wbw_random_sample(x, num_samples = x@source$num_cells() + 1)) \ No newline at end of file +expect_error(wbw_random_sample(x, num_samples = x@source$num_cells() + 1)) diff --git a/tests/tinytest/test_primitives.R b/tests/tinytest/test_primitives.R index 1c52850..140de24 100644 --- a/tests/tinytest/test_primitives.R +++ b/tests/tinytest/test_primitives.R @@ -25,7 +25,6 @@ expect_equal(round(median(x), 4), round(median(v, na.rm = TRUE), 4)) expect_equal(round(wbw::stdev(x), 4), round(sd(v, na.rm = TRUE), 4)) expect_equal(round(variance(x), 1), round(var(v, na.rm = TRUE), 1)) - # Test summary function output s <- capture.output(summary(x)) expect_true(any(grepl("minimum", s))) @@ -33,7 +32,6 @@ expect_true(any(grepl("maximum", s))) expect_true(any(grepl("average", s))) expect_true(any(grepl("standard deviation", s))) - # Test NoData handling exit_if_not(requireNamespace("terra", quietly = TRUE)) r <- wbw_read_raster(f) diff --git a/tests/tinytest/test_print.R b/tests/tinytest/test_print.R index b4e7581..ac2da1e 100644 --- a/tests/tinytest/test_print.R +++ b/tests/tinytest/test_print.R @@ -1,23 +1,22 @@ source("setup.R") # Reading geotiff tags -expected_out <- - c( - "+-----------------------------------------------+ ", - "| WhiteboxRaster |", - "| dem.tif |", - "|...............................................| ", - "| bands : 1 |", - "| dimensions : 726, 800 (nrow, ncol) |", - "| resolution : 5.002392, 5.000243 (x, y) |", - "| EPSG : 2193 (Linear_Meter) |", - "| extent : 1925449 1929446 5582091 5585717 |", - "| min value : 63.698193 |", - "| max value : 361.020721 |", - "+-----------------------------------------------+ " - ) +expected_out <- c( + "+-----------------------------------------------+ ", + "| WhiteboxRaster |", + "| dem.tif |", + "|...............................................| ", + "| bands : 1 |", + "| dimensions : 726, 800 (nrow, ncol) |", + "| resolution : 5.002392, 5.000243 (x, y) |", + "| EPSG : 2193 (Linear_Meter) |", + "| extent : 1925449 1929446 5582091 5585717 |", + "| min value : 63.698193 |", + "| max value : 361.020721 |", + "+-----------------------------------------------+ " +) expect_equal( - paste(utils::capture.output(print(x)), collapse = "\n"), - paste(expected_out, collapse = "\n") + paste(utils::capture.output(print(x)), collapse = "\n"), + paste(expected_out, collapse = "\n") ) diff --git a/tests/tinytest/test_terra.R b/tests/tinytest/test_terra.R index 1f45f36..5853b4c 100644 --- a/tests/tinytest/test_terra.R +++ b/tests/tinytest/test_terra.R @@ -8,32 +8,32 @@ wbwr <- as_rast(x) # Test extent expect_identical( - as.vector(terra::ext(r)), - as.vector(terra::ext(wbwr)) + as.vector(terra::ext(r)), + as.vector(terra::ext(wbwr)) ) # Test content expect_identical( - as.vector(r), - as.vector(wbwr) + as.vector(r), + as.vector(wbwr) ) # Test resolution expect_identical( - terra::res(r), - terra::res(wbwr) + terra::res(r), + terra::res(wbwr) ) # Test CRS expect_identical( - terra::crs(r), - terra::crs(wbwr) + terra::crs(r), + terra::crs(wbwr) ) # Test data type expect_identical( - terra::is.int(r), - terra::is.int(wbwr) + terra::is.int(r), + terra::is.int(wbwr) ) # Test integer data diff --git a/tests/tinytest/test_utils_documentation.R b/tests/tinytest/test_utils_documentation.R index 19893f2..6ac8238 100644 --- a/tests/tinytest/test_utils_documentation.R +++ b/tests/tinytest/test_utils_documentation.R @@ -1,45 +1,45 @@ # Test rd_wbw_link function expected <- paste0( - "@references For more information, see ", - "" + "@references For more information, see ", + "" ) expect_equal(wbw:::rd_wbw_link("slope"), expected) # Test with underscores expected <- paste0( - "@references For more information, see ", - "" + "@references For more information, see ", + "" ) expect_equal(wbw:::rd_wbw_link("breach_depressions"), expected) # Test rd_input_raster function expected <- paste0( - "@param dem Raster object of class [WhiteboxRaster]. ", - "See [wbw_read_raster()] for more details." + "@param dem Raster object of class [WhiteboxRaster]. ", + "See [wbw_read_raster()] for more details." ) expect_equal(wbw:::rd_input_raster("dem"), expected) # Test rd_example function expected <- paste( - "@examples", - 'f <- system.file("extdata/dem.tif", package = "wbw")', - "wbw_read_raster(f) |>", - " slope()", - sep = "\n" + "@examples", + 'f <- system.file("extdata/dem.tif", package = "wbw")', + "wbw_read_raster(f) |>", + " slope()", + sep = "\n" ) expect_equal(wbw:::rd_example("slope"), expected) # Test with arguments expected <- paste( - "@examples", - 'f <- system.file("extdata/dem.tif", package = "wbw")', - "wbw_read_raster(f) |>", - " slope(units = 'degrees')", - sep = "\n" + "@examples", + 'f <- system.file("extdata/dem.tif", package = "wbw")', + "wbw_read_raster(f) |>", + " slope(units = 'degrees')", + sep = "\n" ) expect_equal(wbw:::rd_example("slope", "units = 'degrees'"), expected) @@ -49,4 +49,4 @@ expect_error(wbw:::rd_input_raster("")) expect_error(wbw:::rd_example("")) expect_error(wbw:::rd_wbw_link(NULL)) expect_error(wbw:::rd_input_raster(NULL)) -expect_error(wbw:::rd_example(NULL)) \ No newline at end of file +expect_error(wbw:::rd_example(NULL))