Merge pull request #5 from iiasa/dev

Small NA replacement function

.Rbuildignore

@@ -6,3 +6,4 @@
 ^pkgdown$
 ^LICENSE\.md$
 ^CODE_OF_CONDUCT\.md$
+^\.github$

.github/.gitignore

@@ -0,0 +1 @@
+*.html

.github/workflows/R-CMD-check.yaml

@@ -0,0 +1,50 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, dev]
+  pull_request:
+     branches: [main, dev]
+
+name: r-cmd-check
+
+permissions: read-all
+
+jobs:
+  R-CMD-check:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: macOS-latest, r: 'release'}
+          - {os: windows-latest, r: 'release'}
+          - {os: ubuntu-latest, r: 'release'}
+
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
+
+    steps:
+      - uses: actions/checkout@v4
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::rcmdcheck
+          needs: check
+
+      - uses: r-lib/actions/check-r-package@v2
+        with:
+          upload-snapshots: true
+          build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")'

DESCRIPTION

@@ -1,22 +1,28 @@
 Package: BNRTools
-Title: A suite of convenience functions created by IIASA BNR Researchers.
+Title: A suite of convenience functions created by IIASA BNR Researchers
 Version: 0.1
 Authors@R: 
-    person("Martin", "Jung", , "jung@iiasa", role = c("aut", "cre"),
-           comment = c(ORCID = "0000-0002-7569-1390"))
+    c(person("Martin", "Jung",
+             role = c("aut", "cre"),
+             email = "jung@iiasa",
+             comment = c(ORCID = "0000-0002-7569-1390")), 
+      person("Maximilian H.K.", "Hesselbarth",
+             role = "aut",
+             email = "mhk.hesselbarth@gmail.com",
+             comment = c(ORCID = "0000-0003-1125-9918"))
+      )
 Description: What the package does (one paragraph).
 License: MIT + file LICENSE
-Encoding: UTF-8
-Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
-Depends:
-  dplyr,
+URL: https://github.com/iiasa/BNRTools
+BugReports: https://github.com/iiasa/BNRTools/issues
+Depends: R (>= 3.6)
+Imports:
   assertthat,
-  lubridate,
-  stringr,
-  terra,
-  sf
+  terra
 Suggests:
   gdalUtilities,
   testthat (>= 3.0.0)
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.2
 Config/testthat/edition: 3

NAMESPACE

@@ -1,3 +1,4 @@
 # Generated by roxygen2: do not edit by hand
 
 export(misc_sanitizeNames)
+export(sp_resampleRas)

R/sp_resampleRas.R

@@ -0,0 +1,80 @@
+#' Resample raster
+#'
+#' @description
+#' Resample two raster to the spatial resolution using aggregation or disaggregation.
+#'
+#' @param x A [`SpatRaster`] to be resampled.
+#' @param y A [`SpatRaster`] to which `x` will be resampled
+#' @param discrete [`logical`] to specifiy if input raster has continitous or discrete values
+#'
+#' @returns [`SpatRaster`]
+#'
+#' @keywords spatial
+#'
+#' @seealso
+#' \code{\link[terra]{aggregate}},
+#' \code{\link[terra]{disagg}}
+#'
+#' @examples
+#' set.seed(42)
+#' ras_a <- terra::rast(ncol = 100, nrow = 100, xmin = 0, xmax = 100,
+#' ymin = 0, ymax = 100, resolution = 20, crs = NA)
+#'
+#' ras_b <- terra::rast(ncol = 100, nrow = 100, xmin = 0, xmax = 100,
+#' ymin = 0, ymax = 100, resolution = 5, crs = NA)
+#'
+#'  terra::values(ras_a) <- runif(n = terra::ncell(ras_a))
+#'  terra::values(ras_b) <- runif(n = terra::ncell(ras_b))
+#'
+#'  sp_resampleRas(x = ras_a, y = ras_b)
+#'
+#' @export
+sp_resampleRas <- function(x, y, discrete = FALSE) {
+
+  # MH: Switch this to assertthat::assert_that()
+  # check if CRS are already the same
+  if (!terra::same.crs(x = x, y = y)) stop("No the same CRS!", call. = FALSE)
+
+  # check how many layers are present
+  if (terra::nlyr(x) > 1) stop("Only one layer allowed", call. = FALSE)
+
+  # get factor levels
+  if (discrete) cats_df <- terra::levels(x = x)
+
+  # get resolution
+  res_x <- terra::res(x)
+  res_y <- terra::res(y)
+
+  # get name
+  name_x <- names(x)
+
+  # current resolution finer than scale -> aggregate
+  if (all(res_x < res_y)) {
+
+    x <- suppressWarnings(
+      terra::aggregate(x = x, fact = res_y / res_x, fun = ifelse(test = discrete,
+                                                                 yes = "modal", no = "mean"))
+    )
+
+  # current resolution coarser than scale -> disaggregate
+  } else if (all(res_x > res_y)) {
+
+    x <- suppressWarnings(
+      terra::disagg(x = x, fact = res_x / res_y, method = ifelse(test = discrete,
+                                                                 yes = "near", no = "bilinear"))
+    )
+
+  } else {message("Nothing to do")}
+
+  # re-sample predictor to background raster
+  x <- terra::resample(x = x, y = y, method = ifelse(test = discrete, yes = "near", no = "bilinear"))
+
+  # reset levels
+  if (exists("cats_df")) levels(x) <- cats_df[[1]]
+
+  # make sure name get preserved
+  names(x) <- name_x
+
+  return(x)
+
+}

README.md

@@ -1,9 +1,9 @@
 # BNRTools
 
 <!-- badges: start -->
-
-[![Codecov test coverage](https://codecov.io/gh/iiasa/BNRTools/graph/badge.svg)](https://app.codecov.io/gh/iiasa/BNRTools)
 [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
+[![R-CMD-check](https://github.com/iiasa/BNRTools/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/iiasa/BNRTools/actions/workflows/R-CMD-check.yaml)
+[![Codecov test coverage](https://codecov.io/gh/iiasa/BNRTools/graph/badge.svg)](https://app.codecov.io/gh/iiasa/BNRTools)
 <!-- badges: end -->
 
 This repository contains a common set of functions and scripts used by BNR Researchers. It's purpose is to avoid replication of efforts across different groups and maintain common scripts in a structured way. Use cases might for example include the reprojection to certain grids, the conversion of model output formats to different format types or generic commonly used helper functions.

tests/testthat/test-sp_resampleRas.R

@@ -0,0 +1,16 @@
+ras_a <- terra::rast(ncol = 100, nrow = 100, xmin = 0, xmax = 100,
+ymin = 0, ymax = 100, resolution = 20, crs = NA)
+
+ras_b <- terra::rast(ncol = 100, nrow = 100, xmin = 0, xmax = 100,
+ymin = 0, ymax = 100, resolution = 5, crs = NA)
+
+terra::values(ras_a) <- runif(n = terra::ncell(ras_a))
+terra::values(ras_b) <- runif(n = terra::ncell(ras_b))
+
+test_that("sp_resampleRas results in same resolution/extent", {
+
+  ras_a_res <- sp_resampleRas(x = ras_a, y = ras_b)
+
+  expect_true(terra::compareGeom(ras_a_res, ras_b))
+
+})