diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml new file mode 100644 index 0000000..b64fa5c --- /dev/null +++ b/.github/workflows/check-standard.yaml @@ -0,0 +1,49 @@ +# 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, release/**] + pull_request: + branches: [main, release/**] + +name: R-CMD-check + +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: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v3 + + - 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 diff --git a/.github/workflows/check-standard.yml b/.github/workflows/check-standard.yml deleted file mode 100644 index 68f9322..0000000 --- a/.github/workflows/check-standard.yml +++ /dev/null @@ -1,94 +0,0 @@ -# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. -# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions - -# script obtained 2021-Aug-13 from `usethis::use_github_action("check-standard")` -# added step `Test coverage` (copied relevant sections from `usethis::use_github_action("test-coverage")`) - -on: - push: - branches: - - main - pull_request: - branches: - - main - -name: R-CMD-check-covr - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: windows-latest, r: 'release'} - - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest", http-user-agent: "R/4.1.0 (ubuntu-20.04) R (4.1.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" } - - env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v1 - with: - r-version: ${{ matrix.config.r }} - - - uses: r-lib/actions/setup-pandoc@v1 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Restore R package cache - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - - - name: Install dependencies - run: | - remotes::install_deps(dependencies = TRUE) - remotes::install_cran("rcmdcheck") - shell: Rscript {0} - - - name: Check - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - run: | - options(crayon.enabled = TRUE) - rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check - - - name: Test coverage - if: ${{ runner.os == 'macOS' && success() }} - run: | - remotes::install_cran("covr") - covr::codecov() - shell: Rscript {0} diff --git a/.github/workflows/lint.yaml b/.github/workflows/lint.yaml new file mode 100644 index 0000000..805c988 --- /dev/null +++ b/.github/workflows/lint.yaml @@ -0,0 +1,32 @@ +# 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, release/**] + pull_request: + branches: [main, release/**] + +name: lint + +jobs: + lint: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::lintr, local::. + needs: lint + + - name: Lint + run: lintr::lint_package() + shell: Rscript {0} + env: + LINTR_ERROR_ON_LINT: true diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..940aa45 --- /dev/null +++ b/.github/workflows/test-coverage.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, release/**] + pull_request: + branches: [main, release/**] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: coverage + + - name: Test coverage + run: | + covr::codecov( + quiet = FALSE, + clean = FALSE, + install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") + ) + shell: Rscript {0} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v3 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..9443d51 --- /dev/null +++ b/.lintr @@ -0,0 +1,13 @@ +linters: lintr::linters_with_tags( + tags = NULL, + #--- Change arguments of linters: + line_length_linter = lintr::line_length_linter(length = 80L), + #--- Turn off linters: + implicit_integer_linter = NULL, + object_length_linter = NULL, + object_name_linter = NULL, + todo_comment_linter = NULL, + cyclocomp_linter = NULL, + yoda_test_linter = NULL) +error_on_lint: TRUE +encoding: "UTF-8" diff --git a/DESCRIPTION b/DESCRIPTION index acadc22..48c76d5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rSW2exter Title: Access External Data as Input for SOILWAT2 and STEPWAT2 Simulations -Version: 0.1.1 +Version: 0.2.0 Authors@R: c( person( "Daniel", "Schlaepfer", @@ -17,17 +17,18 @@ Imports: rSW2utils (>= 0.1.0), rSW2st (>= 0.1.0), rSW2data (>= 0.1.0), + terra, raster, reshape2, - sf, - sp + sf Suggests: - FedData, + FedData (>= 3.0.2), soilDB (>= 2.5.7), + sp, utils, testthat (>= 3.0.0), spelling, - lintr, + lintr (>= 3.0.0), covr Remotes: github::DrylandEcology/rSW2utils, @@ -37,7 +38,6 @@ License: GPL-3 URL: https://github.com/DrylandEcology/rSW2exter BugReports: https://github.com/DrylandEcology/rSW2exter/issues Encoding: UTF-8 -LazyData: true Config/testthat/edition: 3 Language: en-US -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.3 diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..adc5bde --- /dev/null +++ b/NEWS.md @@ -0,0 +1,15 @@ +# rSW2exter v0.2.0 +* `fetch_mukeys_spatially_NRCS_SDA()` now handles versions of "soilDB" + from `2.5.7` to at least `2.6.14`. +* `extract_soils_NRCS_SDA()` queries include now `localphase`; + this should improve the ability to identify a component of a soil map unit + across NRCS data releases by a combination of + `compname`, `comppct_r`, `localphase`. +* `extract_soils_NRCS_SDA()` gains argument `only_soilcomp` which excludes + non-soil components, i.e., those that are not "Miscellaneous areas" and + are not "NOTCOM" (not completed). +* Linting updated to `lintr` >= 3 and + lint workflow switched from package tests to Github Action (#5). + +# rSW2exter v0.1.0 +Initial release diff --git a/R/extract_soils_Miller1998_CONUSSoils.R b/R/extract_soils_Miller1998_CONUSSoils.R index 74c681a..ead7522 100644 --- a/R/extract_soils_Miller1998_CONUSSoils.R +++ b/R/extract_soils_Miller1998_CONUSSoils.R @@ -32,7 +32,7 @@ create_reference_for_Miller1998_CONUSSoil <- function() { "Miller, D. A., and R. A. White. 1998. A conterminous United States ", "multilayer soil characteristics dataset for regional climate and ", "hydrology modeling. Earth Interactions 2:1-26. ", - "https://doi.org/10.1175%2F1087-3562%281998%29002%3C0001%3AACUSMS%3E2.3.CO%3B2 ", # nolint + "https://doi.org/10.1175%2F1087-3562%281998%29002%3C0001%3AACUSMS%3E2.3.CO%3B2 ", # nolint: line_length_linter "Data accessed [", format(as.POSIXlt(Sys.Date()), "%Y-%b-%e"), "]" @@ -106,7 +106,7 @@ prepare_script_for_Miller1998_CONUSSoil <- function( #' #' @export create_conditioned_Miller1998_CONUSSoil <- function( - path, + path = ".", vars = c("rockdepm", "rockvol", "bd", "sand", "clay", "silt"), lower_limits_by_vars = c( rockdepm = 0, rockvol = 0, bd = 30, sand = 0, clay = 0, silt = 0 @@ -215,7 +215,7 @@ check_Miller1998_CONUSSoil <- function( ) ) { - sapply( + vapply( vars, function(var) { file.exists(filepath_Miller1998_CONUSSoil( @@ -223,7 +223,8 @@ check_Miller1998_CONUSSoil <- function( var = var, lower_limit = lower_limits_by_vars[var] )) - } + }, + FUN.VALUE = NA ) } @@ -253,8 +254,8 @@ fetch_soils_from_Miller1998_CONUSSoil <- function( # Align with data crs ftmp <- filepath_Miller1998_CONUSSoil( path = path, - var = vars[1], - lower_limit = lower_limits_by_vars[vars[1]] + var = vars[[1L]], + lower_limit = lower_limits_by_vars[vars[[1L]]] ) tmp_crs <- sf::st_crs(raster::brick(ftmp)) @@ -292,7 +293,7 @@ fetch_soils_from_Miller1998_CONUSSoil <- function( method = "simple" ) - # nolint start + # nolint start: commented_code_linter # tmp <- do.call( # "extract_rSFSW2", # args = list( @@ -312,7 +313,9 @@ fetch_soils_from_Miller1998_CONUSSoil <- function( } } else { - stop("Miller1998/CONUSSoil data ", shQuote(basename(ftmp)), " not found.") + stop( + "Miller1998 (CONUSSoil) data ", shQuote(basename(ftmp)), " not found." + ) } } @@ -377,7 +380,7 @@ fetch_soils_from_Miller1998_CONUSSoil <- function( extract_soils_Miller1998_CONUSSoil <- function( x, crs = 4326, - path, + path = ".", vars = c("bd", "rockvol", "sand", "clay", "silt"), lower_limits_by_vars = c(bd = 30, rockvol = 0, sand = 0, clay = 0, silt = 0), replace_missing_fragvol_with_zero = c("none", "all", "at_surface"), @@ -410,7 +413,7 @@ extract_soils_Miller1998_CONUSSoil <- function( verbose = verbose ) - N_layers <- dim(res)[3] + N_layers <- dim(res)[[3L]] # Calculate restriction depth by >99% rock volume @@ -595,9 +598,10 @@ extract_soils_Miller1998_CONUSSoil <- function( formula = id ~ Horizon_No + variable ) - colnames(locs_table_texture) <- sapply( - X = strsplit(colnames(locs_table_texture), split = "_"), - FUN = function(x) paste0(x[2], "_L", x[1]) + colnames(locs_table_texture) <- vapply( + X = strsplit(colnames(locs_table_texture), split = "_", fixed = TRUE), + FUN = function(x) paste0(x[[2L]], "_L", x[[1L]]), + FUN.VALUE = NA_character_ ) diff --git a/R/extract_soils_NRCS_SDA.R b/R/extract_soils_NRCS_SDA.R index 5917397..daf114a 100644 --- a/R/extract_soils_NRCS_SDA.R +++ b/R/extract_soils_NRCS_SDA.R @@ -26,7 +26,7 @@ create_reference_for_NRCS_SDA <- function() { #' representing mineral soils. \code{NA}s in the input propagate. #' #' @references Code based on \var{CheckTexture()} version \var{2020-Aug-31} from -# nolint start +# nolint start: line_length_linter #' \url{https://github.com/ncss-tech/SoilDataDevelopmentToolbox/blob/master/SDA_Valu2Table.py} # nolint end #' @@ -128,7 +128,7 @@ is_NRCS_horizon_organic <- function(x) { #' } #' #' @references Code based on \var{CalcRZDepth()} version 2020-08-31: -# nolint start +# nolint start: line_length_linter #' \url{https://github.com/ncss-tech/SoilDataDevelopmentToolbox/blob/master/SDA_Valu2Table.py} # nolint end #' Note: currently ignores "dense" layer restrictions @@ -230,15 +230,25 @@ calculate_soil_depth_NRCS <- function( data = x, INDICES = x[, var_site_id], FUN = function(xc) { - is_ec_restricted <- + ids_ec_restricted <- which( xc[, "check"] & !is.na(xc[, "ec_r"]) & xc[, "ec_r"] >= 16 - is_ph_restricted <- + ) + ids_ph_restricted <- which( xc[, "check"] & !is.na(xc[, "ph1to1h2o_r"]) & xc[, "ph1to1h2o_r"] <= 3.5 + ) c( - ec_restriction_depth = xc[which(is_ec_restricted)[1], "hzdept_r"], - ph_restriction_depth = xc[which(is_ph_restricted)[1], "hzdept_r"] + ec_restriction_depth = if (length(ids_ec_restricted) > 0) { + xc[ids_ec_restricted[[1L]], "hzdept_r"] + } else { + NA + }, + ph_restriction_depth = if (length(ids_ph_restricted) > 0) { + xc[ids_ph_restricted[[1L]], "hzdept_r"] + } else { + NA + } ) }, simplify = FALSE @@ -309,13 +319,13 @@ calculate_soil_depth_NRCS <- function( X = locs_table_depths, MARGIN = 1, FUN = function(x) { - findInterval(x[1], c(0, na.exclude(x[-1])), left.open = TRUE) + findInterval(x[[1L]], c(0, na.exclude(x[-1])), left.open = TRUE) } ) ids <- which(!apply( X = locs_table_depths, MARGIN = 1, - FUN = function(x) x[1] == 0 || all(is.na(x[-1])) || x[1] %in% x[-1] + FUN = function(x) x[[1L]] == 0 || all(is.na(x[-1])) || x[[1L]] %in% x[-1] )) locs_table_depths[cbind(ids, 1 + L_at_soildepth[ids])] <- locs_table_depths[ids, "SoilDepth_cm"] @@ -330,7 +340,9 @@ calculate_soil_depth_NRCS <- function( locs_table_depths ), MARGIN = 1, - FUN = function(x) !anyNA(x[1:2]) & x[1] > 0 & x[2] > 0 & x[3] %in% c(0, NA) + FUN = function(x) { + !anyNA(x[1:2]) & x[[1L]] > 0 & x[[2L]] > 0 & x[[3L]] %in% c(0, NA) + } ) locs_table_depths[ids, "depth_L1"] <- locs_table_depths[ids, "SoilDepth_cm"] @@ -344,7 +356,9 @@ calculate_soil_depth_NRCS <- function( locs_table_depths ), MARGIN = 1, - FUN = function(x) !anyNA(x[1:2]) & x[1] == 0 & x[2] > 0 & x[3] %in% c(0, NA) + FUN = function(x) { + !anyNA(x[1:2]) & x[[1L]] == 0 & x[[2L]] > 0 & x[[3L]] %in% c(0, NA) + } ) locs_table_depths[ids, "SoilDepth_cm"] <- 0 @@ -358,7 +372,7 @@ calculate_soil_depth_NRCS <- function( locs_table_depths ), MARGIN = 1, - FUN = function(x) !is.na(x[1]) & x[1] == 0 & x[2] > 0 + FUN = function(x) !is.na(x[[1L]]) & x[[1L]] == 0 & x[[2L]] > 0 ) locs_table_depths[ids, "SoilDepth_cm"] <- 0 @@ -373,7 +387,11 @@ calculate_soil_depth_NRCS <- function( ), MARGIN = 1, FUN = function(x) { - !is.na(x[1]) & x[1] > 0 & x[2] == 0 & !is.na(x[3]) & x[3] > 0 + !is.na(x[[1L]]) & + x[[1L]] > 0 & + x[[2L]] == 0 & + !is.na(x[[3L]]) & + x[[3L]] > 0 } ) locs_table_depths[ids, "SoilDepth_cm"] <- locs_table_depths[ids, "depth_L1"] @@ -389,7 +407,7 @@ calculate_soil_depth_NRCS <- function( N_horizons = apply( X = locs_table_depths[, -1, drop = FALSE], MARGIN = 1, - function(x) sum(!is.na(x)) + function(x) as.integer(sum(!is.na(x))) ), depth_L = locs_table_depths ) @@ -452,6 +470,7 @@ fetch_mukeys_spatially_NRCS_SDA <- function( locations <- rSW2st::as_points(x, to_class = "sf", crs = crs) nxlocs <- nrow(locations) } else { + stopifnot(requireNamespace("sp")) locations <- rSW2st::as_points(x, to_class = "sp", crs = crs) nxlocs <- length(locations) } @@ -510,10 +529,13 @@ fetch_mukeys_spatially_NRCS_SDA <- function( # return values of `SDA_spatialQuery` are not ordered by input `geom` # (unless `byFeature = TRUE` since v2.6.10) res[[k]] <- if (inherits(locations, "sf")) { - ids <- unlist(unclass(sf::st_intersects(locations, res_mukeys))) + ids <- unlist(unclass( + sf::st_intersects(locations[ids_chunks[[k]], ], res_mukeys) + )) as.vector(res_mukeys[ids, "mukey", drop = TRUE]) } else if (inherits(locations, "Spatial")) { + # sp is only used if soilDB < 2.6.10 sp::over( x = sp::spTransform( locations[ids_chunks[[k]], ], @@ -635,13 +657,18 @@ fetch_soils_from_NRCS_SDA <- function( res <- list() # trim off comments at top of file - sql_base <- sql_template[-{1:(grep("SELECT", sql_template)[1] - 1)}] + tmp_ids <- seq_len(grep("SELECT", sql_template, fixed = TRUE)[[1L]] - 1L) + sql_base <- if (length(tmp_ids) > 0) { + sql_template[-tmp_ids] + } else { + sql_template + } # remove majcompflag (may be necessary for STATSGO) if (majcompflag == "ignore") { txt_majcompflag <- "AND component.majcompflag = 'Yes'" tmp <- regexpr(txt_majcompflag, sql_base, fixed = TRUE) - iline <- which(tmp > 0)[1] + iline <- which(tmp > 0)[[1L]] sql_base[iline] <- sub(txt_majcompflag, "", sql_base[iline]) } @@ -649,7 +676,7 @@ fetch_soils_from_NRCS_SDA <- function( if (!only_soilcomp) { txt_nosoilflag <- "compkind NOT IN" tmp <- regexpr(txt_nosoilflag, sql_base, fixed = TRUE) - iline <- which(tmp > 0)[1] + iline <- which(tmp > 0)[[1L]] sql_base[iline] <- "" } @@ -672,7 +699,7 @@ fetch_soils_from_NRCS_SDA <- function( # Identify lines where mukey values are injected tmp <- regexpr("mukey IN (%s)", sql_base, fixed = TRUE) - iline <- which(tmp > 0)[1] + iline <- which(tmp > 0)[[1L]] for (k in seq_along(ids_chunks)) { @@ -862,7 +889,7 @@ fetch_soils_from_NRCS_SDA <- function( extract_soils_NRCS_SDA <- function( x, crs = 4326, - mukeys, + mukeys = NULL, method = c("SSURGO", "STATSGO", "SSURGO_then_STATSGO"), sql_template = NA, only_majcomp = TRUE, @@ -883,9 +910,9 @@ extract_soils_NRCS_SDA <- function( } stopifnot( - !(missing(x) && missing(mukeys)), + !(missing(x) && is.null(mukeys)), curl::has_internet(), - missing(x) || missing(mukeys) || nrow(x) == length(mukeys) + missing(x) || is.null(mukeys) || nrow(x) == length(mukeys) ) method <- match.arg(method) @@ -903,7 +930,7 @@ extract_soils_NRCS_SDA <- function( row_id = NA, unit_id = NA, source = db, - mukey = if (missing(mukeys)) { + mukey = if (is.null(mukeys)) { fetch_mukeys_spatially_NRCS_SDA( x = x, crs = crs, @@ -936,7 +963,7 @@ extract_soils_NRCS_SDA <- function( tmp_tag <- apply( locs_keys[, c("mukey", "compname", "comppct_r", "localphase")], MARGIN = 1, - FUN = function(x) paste0(as.integer(x[1]), "_", x[2]) + FUN = function(x) paste0(as.integer(x[[1L]]), "_", x[[2L]]) ) locs_keys[, "unit_id"] <- match(tmp_tag, unique(tmp_tag)) } @@ -965,7 +992,7 @@ extract_soils_NRCS_SDA <- function( tmp_tag2 <- apply( res[, c("MUKEY", "compname", "comppct_r", "localphase")], MARGIN = 1, - FUN = function(x) paste0(as.integer(x[1]), "_", x[2]) + FUN = function(x) paste0(as.integer(x[[1L]]), "_", x[[2L]]) ) ids <- match(tmp_tag2, tmp_tag) res[, "unit_id"] <- locs_keys[ids, "unit_id"] @@ -997,7 +1024,7 @@ extract_soils_NRCS_SDA <- function( data = res, INDICES = res[["unit_id"]], FUN = function(x) { - sapply( + vapply( X = x, FUN = function(v) { if (is.numeric(v)) { @@ -1005,7 +1032,8 @@ extract_soils_NRCS_SDA <- function( } else { nlevels(factor(v)) > 1 } - } + }, + FUN.VALUE = NA ) }, simplify = FALSE @@ -1103,7 +1131,7 @@ extract_soils_NRCS_SDA <- function( FUN = function(x) { # First element corresponds to TRUE # because we only look at soil units with an organic surface horizon - n <- rle(x)[["lengths"]][1] + n <- rle(x)[["lengths"]][[1L]] c(rep(TRUE, n), rep(FALSE, length(x) - n)) }, simplify = FALSE @@ -1162,11 +1190,11 @@ extract_soils_NRCS_SDA <- function( xnew[, "Horizon_No"] <- seq_len(n) # Re-calculate upper/lower horizon depth limits - ids <- grep("hzdep", colnames(xnew)) + ids <- grep("hzdep", colnames(xnew), fixed = TRUE) xnew[, ids] <- xnew[, ids] - removed_widths # Re-calculate depth restrictions - ids <- grep("_depth", colnames(xnew)) + ids <- grep("_depth", colnames(xnew), fixed = TRUE) xnew[, ids] <- xnew[, ids] - removed_total } else { @@ -1187,7 +1215,7 @@ extract_soils_NRCS_SDA <- function( # Put data back together res <- rbind( res[-ids_affected, ], - tmp[, !grepl("remove", colnames(tmp))] + tmp[, !grepl("remove", colnames(tmp), fixed = TRUE)] ) } } @@ -1285,9 +1313,10 @@ extract_soils_NRCS_SDA <- function( ids <- match(locs_keys[, "unit_id"], rownames(tmp_texture), nomatch = NA) locs_table_texture <- tmp_texture[ids, , drop = FALSE] - colnames(locs_table_texture) <- sapply( - X = strsplit(colnames(locs_table_texture), split = "_"), - FUN = function(x) paste0(x[2], "_L", x[1]) + colnames(locs_table_texture) <- vapply( + X = strsplit(colnames(locs_table_texture), split = "_", fixed = TRUE), + FUN = function(x) paste0(x[[2L]], "_L", x[[1L]]), + FUN.VALUE = NA_character_ ) rownames(locs_table_texture) <- locs_keys[, "row_id"] diff --git a/R/extract_soils_POLARIS.R b/R/extract_soils_POLARIS.R index 65dc6f7..07d3d05 100644 --- a/R/extract_soils_POLARIS.R +++ b/R/extract_soils_POLARIS.R @@ -52,7 +52,7 @@ prepare_script_for_POLARIS <- function( ) { dir.create(path, recursive = TRUE, showWarnings = FALSE) - bash_shebang <- "#!/bin/bash" + bash_shebang <- "#!/bin/bash" # nolint: nonportable_path_linter wget <- paste0( "wget -nc -c --recursive --no-parent --no-host-directories --cut-dirs=1 ", @@ -187,7 +187,7 @@ check_POLARIS <- function( m = gregexpr(paste0(path, ".+?\\.(tif|vrt)"), x) ) - res["tif", k1, k2, k3] <- all(file.exists(ftmps[[1]])[-1]) + res["tif", k1, k2, k3] <- all(file.exists(ftmps[[1L]])[-1]) } } } @@ -222,8 +222,16 @@ check_POLARIS <- function( #' \doi{10.1029/2018WR022797}. #' #' @export -fetch_soils_from_POLARIS <- function(x, crs, - vars, stat, path, buffer_m = NULL, fun = NULL, na.rm = TRUE, verbose = FALSE +fetch_soils_from_POLARIS <- function( + x, + crs, + vars, + stat, + path = ".", + buffer_m = NULL, + fun = NULL, + na.rm = TRUE, + verbose = FALSE ) { depths <- depth_profile_POLARIS() @@ -250,7 +258,8 @@ fetch_soils_from_POLARIS <- function(x, crs, if (verbose) { message( Sys.time(), - " extracting ", vars[iv], " at ", sub("_", "-", depths[id]), " cm" + " extracting ", vars[iv], " at ", + sub("_", "-", depths[id], fixed = TRUE), " cm" ) } @@ -389,7 +398,7 @@ extract_soils_POLARIS <- function( crs = 4326, vars = c("bd", "sand", "clay", "silt"), stat = "mean", - path, + path = ".", method = c("asis", "fix_with_buffer"), fix_criteria = list( bd = list(op = "<", value = 0.6), @@ -423,7 +432,7 @@ extract_soils_POLARIS <- function( verbose = verbose ) - N_layers <- dim(res)[3] + N_layers <- dim(res)[[3L]] #--- Attempt to replace sites with problematic values by buffered extractions @@ -431,17 +440,18 @@ extract_soils_POLARIS <- function( # Determine for which variables we have criteria to determine problems tmp <- intersect(c(vars, "texture"), names(fix_criteria)) - ok <- sapply( + ok <- vapply( X = fix_criteria[tmp], - FUN = function(x) all(c("op", "value") %in% names(x)) + FUN = function(x) all(c("op", "value") %in% names(x)), + FUN.VALUE = NA ) check_vars <- tmp[ok] # Is `fix_criteria` well formed? - if (any(!ok)) { + if (!all(ok)) { warning( "Cannot apply `fix_with_buffer` for ", - paste(shQuote(tmp[!ok]), collapse = ", "), + toString(shQuote(tmp[!ok])), " because of incomplete criteria." ) } @@ -453,10 +463,10 @@ extract_soils_POLARIS <- function( ok <- if (one_fun) TRUE else check_vars %in% names(fun) # Is `fun` well formed? - if (any(!ok)) { + if (!all(ok)) { warning( "Cannot apply `fix_with_buffer` for ", - paste(shQuote(tmp[!ok]), collapse = ", "), + toString(shQuote(tmp[!ok])), " because of missing summarizing function `fun`." ) } @@ -470,7 +480,7 @@ extract_soils_POLARIS <- function( warning( "Cannot apply `fix_with_buffer` for `texture` because of ", "missing texture variables: ", - paste(shQuote(var_stxt3[hasnot_texture]), collapse = ", ") + toString(shQuote(var_stxt3[hasnot_texture])) ) } else { @@ -503,7 +513,13 @@ extract_soils_POLARIS <- function( } } - check_vars <- grep("texture", check_vars, value = TRUE, invert = TRUE) + check_vars <- grep( + "texture", + x = check_vars, + value = TRUE, + invert = TRUE, + fixed = TRUE + ) } # Fix for all other variables @@ -582,9 +598,10 @@ extract_soils_POLARIS <- function( #--- Set (fixed) soil depth of profile in wide-format for output - layer_depths <- as.integer(sapply( - X = strsplit(depth_profile_POLARIS(), split = "_"), - FUN = function(x) x[2] + layer_depths <- as.integer(vapply( + X = strsplit(depth_profile_POLARIS(), split = "_", fixed = TRUE), + FUN = function(x) x[[2L]], + FUN.VALUE = NA_character_ )) locs_table_depths <- cbind( diff --git a/R/extract_topography_NEDUSA.R b/R/extract_topography_NEDUSA.R index 9f0eb82..af524fb 100644 --- a/R/extract_topography_NEDUSA.R +++ b/R/extract_topography_NEDUSA.R @@ -59,9 +59,9 @@ #' to_class = "sf", #' crs = 4326 #' ) -#' extent_polygon <- FedData::polygon_from_extent( -#' x = 1.1 * raster::extent(locations), -#' proj4string = "+init=epsg:4326" +#' extent_polygon <- terra::vect( +#' 1.1 * terra::ext(locations), +#' crs = terra::crs(locations) #' ) #' #' ### Download NED @@ -74,13 +74,11 @@ #' #' ### Derive slope and aspect #' for (opt in c("slope", "aspect")) { -#' tmp <- raster::terrain( +#' tmp <- terra::terrain( #' x = ned_1s_example, -#' opt = opt, +#' v = opt, #' unit = "degrees", -#' filename = filenames_ned_examples[[opt]], -#' datatype = "FLT4S", -#' options = c("COMPRESS=DEFLATE", "ZLEVEL=9", "INTERLEAVE=BAND") +#' filename = filenames_ned_examples[[opt]] #' ) #' } #' @@ -107,7 +105,7 @@ extract_topography_NEDUSA <- function( x, crs = 4326, - path, + path = ".", file_datasets = list( elev = "ned_1s.tif", slope = file.path("terrain", "slope_ned_1s.tif"), @@ -140,17 +138,18 @@ extract_topography_NEDUSA <- function( #--- Load topographic data - rtopo <- raster::stack(filepaths_topo[has_topo]) - + rtopo <- terra::rast(unlist(filepaths_topo[has_topo])) + names(rtopo) <- names(filepaths_topo[has_topo]) #--- Extract values locations <- rSW2st::as_points(x, to_class = "sf", crs = crs) locs_tmp <- sf::st_transform(locations, crs = sf::st_crs(rtopo)) - vals_topo <- raster::extract( + vals_topo <- terra::extract( rtopo, locs_tmp, - method = method + method = method, + ID = FALSE ) diff --git a/README.md b/README.md index d32b57b..f779849 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [ ![R build status][1]][2] [ ![github release][5]][6] [![license][7]][8] [![codecov status][9]][10] -[1]: https://github.com/DrylandEcology/rSW2exter/actions/workflows/check-standard.yml/badge.svg?branch=main +[1]: https://github.com/DrylandEcology/rSW2exter/actions/workflows/check-standard.yaml/badge.svg?branch=main [2]: https://github.com/DrylandEcology/rSW2exter/actions [5]: https://img.shields.io/github/release/DrylandEcology/rSW2exter.svg?label=current+release [6]: https://github.com/DrylandEcology/rSW2exter/releases diff --git a/man/check_Miller1998_CONUSSoil.Rd b/man/check_Miller1998_CONUSSoil.Rd index 7a3c56d..1e7f2cf 100644 --- a/man/check_Miller1998_CONUSSoil.Rd +++ b/man/check_Miller1998_CONUSSoil.Rd @@ -7,8 +7,8 @@ check_Miller1998_CONUSSoil( path = ".", vars = c("rockdepm", "rockvol", "bd", "sand", "clay", "silt"), - lower_limits_by_vars = c(rockdepm = 0, rockvol = 0, bd = 30, sand = 0, clay = 0, silt - = 0) + lower_limits_by_vars = c(rockdepm = 0, rockvol = 0, bd = 30, sand = 0, clay = 0, silt = + 0) ) } \arguments{ diff --git a/man/create_conditioned_Miller1998_CONUSSoil.Rd b/man/create_conditioned_Miller1998_CONUSSoil.Rd index 4f5d603..722de2e 100644 --- a/man/create_conditioned_Miller1998_CONUSSoil.Rd +++ b/man/create_conditioned_Miller1998_CONUSSoil.Rd @@ -5,10 +5,10 @@ \title{Mask out unrealistic variable values in \var{CONUSSoil}} \usage{ create_conditioned_Miller1998_CONUSSoil( - path, + path = ".", vars = c("rockdepm", "rockvol", "bd", "sand", "clay", "silt"), - lower_limits_by_vars = c(rockdepm = 0, rockvol = 0, bd = 30, sand = 0, clay = 0, silt - = 0) + lower_limits_by_vars = c(rockdepm = 0, rockvol = 0, bd = 30, sand = 0, clay = 0, silt = + 0) ) } \arguments{ diff --git a/man/extract_soils_Miller1998_CONUSSoil.Rd b/man/extract_soils_Miller1998_CONUSSoil.Rd index 5fa1e73..2457338 100644 --- a/man/extract_soils_Miller1998_CONUSSoil.Rd +++ b/man/extract_soils_Miller1998_CONUSSoil.Rd @@ -8,7 +8,7 @@ for \pkg{SOILWAT2} applications} extract_soils_Miller1998_CONUSSoil( x, crs = 4326, - path, + path = ".", vars = c("bd", "rockvol", "sand", "clay", "silt"), lower_limits_by_vars = c(bd = 30, rockvol = 0, sand = 0, clay = 0, silt = 0), replace_missing_fragvol_with_zero = c("none", "all", "at_surface"), @@ -31,7 +31,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} diff --git a/man/extract_soils_NRCS_SDA.Rd b/man/extract_soils_NRCS_SDA.Rd index bd00fe1..cbc8154 100644 --- a/man/extract_soils_NRCS_SDA.Rd +++ b/man/extract_soils_NRCS_SDA.Rd @@ -8,7 +8,7 @@ extract_soils_NRCS_SDA( x, crs = 4326, - mukeys, + mukeys = NULL, method = c("SSURGO", "STATSGO", "SSURGO_then_STATSGO"), sql_template = NA, only_majcomp = TRUE, @@ -38,7 +38,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} diff --git a/man/extract_soils_POLARIS.Rd b/man/extract_soils_POLARIS.Rd index f507164..b6115e7 100644 --- a/man/extract_soils_POLARIS.Rd +++ b/man/extract_soils_POLARIS.Rd @@ -10,10 +10,10 @@ extract_soils_POLARIS( crs = 4326, vars = c("bd", "sand", "clay", "silt"), stat = "mean", - path, + path = ".", method = c("asis", "fix_with_buffer"), - fix_criteria = list(bd = list(op = "<", value = 0.6), texture = list(op = "<", value - = 0.5)), + fix_criteria = list(bd = list(op = "<", value = 0.6), texture = list(op = "<", value = + 0.5)), buffer_m = NULL, fun = NULL, na.rm = TRUE, @@ -35,7 +35,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} diff --git a/man/extract_topography_NEDUSA.Rd b/man/extract_topography_NEDUSA.Rd index ec4d7cb..1ebda5b 100644 --- a/man/extract_topography_NEDUSA.Rd +++ b/man/extract_topography_NEDUSA.Rd @@ -8,7 +8,7 @@ extract_topography_NEDUSA( x, crs = 4326, - path, + path = ".", file_datasets = list(elev = "ned_1s.tif", slope = file.path("terrain", "slope_ned_1s.tif"), aspect = file.path("terrain", "aspect_ned_1s.tif")), units_slope = c("degrees", "radians"), @@ -32,7 +32,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} @@ -108,9 +108,9 @@ if (requireNamespace("FedData") && curl::has_internet()) { to_class = "sf", crs = 4326 ) - extent_polygon <- FedData::polygon_from_extent( - x = 1.1 * raster::extent(locations), - proj4string = "+init=epsg:4326" + extent_polygon <- terra::vect( + 1.1 * terra::ext(locations), + crs = terra::crs(locations) ) ### Download NED @@ -123,13 +123,11 @@ if (requireNamespace("FedData") && curl::has_internet()) { ### Derive slope and aspect for (opt in c("slope", "aspect")) { - tmp <- raster::terrain( + tmp <- terra::terrain( x = ned_1s_example, - opt = opt, + v = opt, unit = "degrees", - filename = filenames_ned_examples[[opt]], - datatype = "FLT4S", - options = c("COMPRESS=DEFLATE", "ZLEVEL=9", "INTERLEAVE=BAND") + filename = filenames_ned_examples[[opt]] ) } diff --git a/man/fetch_mukeys_spatially_NRCS_SDA.Rd b/man/fetch_mukeys_spatially_NRCS_SDA.Rd index 4023b2a..e0a521f 100644 --- a/man/fetch_mukeys_spatially_NRCS_SDA.Rd +++ b/man/fetch_mukeys_spatially_NRCS_SDA.Rd @@ -28,7 +28,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} diff --git a/man/fetch_soils_from_Miller1998_CONUSSoil.Rd b/man/fetch_soils_from_Miller1998_CONUSSoil.Rd index 50134e5..35815ed 100644 --- a/man/fetch_soils_from_Miller1998_CONUSSoil.Rd +++ b/man/fetch_soils_from_Miller1998_CONUSSoil.Rd @@ -27,7 +27,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} diff --git a/man/fetch_soils_from_POLARIS.Rd b/man/fetch_soils_from_POLARIS.Rd index a382819..f274ed4 100644 --- a/man/fetch_soils_from_POLARIS.Rd +++ b/man/fetch_soils_from_POLARIS.Rd @@ -9,7 +9,7 @@ fetch_soils_from_POLARIS( crs, vars, stat, - path, + path = ".", buffer_m = NULL, fun = NULL, na.rm = TRUE, @@ -30,7 +30,7 @@ be numeric as a \var{EPSG} number; a character string as a \var{wkt}; a character string as a \var{proj4} (not recommended because outdated); or of a class including - \code{\link[raster:Raster-classes]{raster::Raster}}, + \code{\link[raster:Raster-class]{raster::Raster}}, \code{\link[sp:Spatial-class]{sp::Spatial}}, \code{\link[sp:CRS-class]{sp::CRS}}, or a \code{\link[sf]{sf}} or \code{\link[sf]{sfc}} class.} diff --git a/tests/lint_code.R b/tests/lint_code.R deleted file mode 100644 index 30a3427..0000000 --- a/tests/lint_code.R +++ /dev/null @@ -1,201 +0,0 @@ -#--- Code style - -# nolint start - -# Problem: `R CMD check` doesn't allow hidden files -# including the lintr settings; thus, we exclude `.lintr` via `.Rbuildignore`. -# Consequently, we wouldn't be able to lint with our settings -# during package checks with `R CMD check`/`devtools::check()`. - -# ==> Configure linters here in code instead of via file `.lintr` - - -# The linting code can be run via any the following options -# (assuming the current working directory is at the root of the source package) -# - `Sys.setenv(NOT_CRAN = "true"); source("tests/lint_code.R")` -# - `devtools::check(env_vars = c(NOT_CRAN = "true"))` -# - `R CMD build . && NOT_CRAN="true" R CMD check *.tar.gz` - -# nolint end - -if ( - requireNamespace( - "lintr", - versionCheck = list(op = ">=", version = "2.0") - ) && - # skip_on_cran - isTRUE(tolower(Sys.getenv("NOT_CRAN")) %in% c(1, "yes", "true")) && - # skip_on_appveyor - !isTRUE(tolower(Sys.getenv("APPVEYOR")) %in% c(1, "yes", "true")) && - # skip_on_covr - !isTRUE(tolower(Sys.getenv("R_COVR")) %in% c(1, "yes", "true")) -) { - - # Locate package source directory - is_package_source_path <- function(path) { - dir.exists(path) && file.exists(file.path(path, "DESCRIPTION")) - } - - # During interactive session and sourcing the file - pkg_path <- "." - - # During unit testing, the current path is set to `tests/testthat/` - if (!is_package_source_path(pkg_path)) { - pkg_path <- file.path("..", "..") - - if (!is_package_source_path(pkg_path)) { - # During package checks, the current path is a temporary build directory - # Code chunk based on `spelling::spell_check_test` - if (!is_package_source_path(pkg_path)) { - pkg_path <- list.files(file.path("..", "00_pkg_src"), full.names = TRUE) - - if (!length(pkg_path)) { - check_dir <- dirname(getwd()) - if (grepl("\\.Rcheck$", check_dir)) { - source_dir <- sub("\\.Rcheck$", "", check_dir) - if (file.exists(source_dir)) { - pkg_path <- source_dir - } - } - } - } - } - } - - - if (is_package_source_path(pkg_path)) { - - #--- List files that shouldn't be linted - files_not_tolint <- file.path( - "R", - "RcppExports.R" - ) - - #--- List of linters to apply to package code - linters_config <- lintr::with_defaults( - #------ DEFAULT LINTERS - assignment_linter = lintr::assignment_linter, - closed_curly_linter = - lintr::closed_curly_linter(allow_single_line = TRUE), - commas_linter = lintr::commas_linter, - commented_code_linter = lintr::commented_code_linter, - equals_na_linter = lintr::equals_na_linter, - function_left_parentheses_linter = - lintr::function_left_parentheses_linter, - infix_spaces_linter = lintr::infix_spaces_linter, - line_length_linter = lintr::line_length_linter(length = 80L), - no_tab_linter = lintr::no_tab_linter, - object_length_linter = lintr::object_length_linter, - object_usage_linter = lintr::object_usage_linter, - open_curly_linter = lintr::open_curly_linter(allow_single_line = TRUE), - paren_brace_linter = lintr::paren_brace_linter, - pipe_continuation_linter = lintr::pipe_continuation_linter, - seq_linter = lintr::seq_linter, - single_quotes_linter = lintr::single_quotes_linter, - spaces_inside_linter = lintr::spaces_inside_linter, - spaces_left_parentheses_linter = lintr::spaces_left_parentheses_linter, - trailing_blank_lines_linter = lintr::trailing_blank_lines_linter, - trailing_whitespace_linter = lintr::trailing_whitespace_linter, - #--- Turn off default linters for now: - object_name_linter = NULL, - cyclocomp_linter = NULL, - #------ NON-DEFAULT LINTERS - #--- Not activated non-default linters: - # lintr::extraction_operator_linter, - # lintr::implicit_integer_linter, - # lintr::todo_comment_linter, - # see https://github.com/jimhester/lintr/issues/468 - # nonportable_path_linter = lintr::nonportable_path_linter(lax = TRUE), - #--- Activated non-default linters: - absolute_path_linter = lintr::absolute_path_linter(lax = TRUE), - infix_spaces_linter = lintr::infix_spaces_linter, - T_and_F_symbol_linter = lintr::T_and_F_symbol_linter, - semicolon_terminator_linter = lintr::semicolon_terminator_linter( - semicolon = c("compound", "trailing") - ), - undesirable_function_linter = lintr::undesirable_function_linter, - undesirable_operator_linter = lintr::undesirable_operator_linter, - unneeded_concatenation_linter = lintr::unneeded_concatenation_linter - ) - - - #--- Lint package code - # `lintr::expect_lint_free` and `lintr::lint_package` lint R code - # only in "R", "tests", "inst" - paths <- file.path( - pkg_path, - c("data-raw", "demo", "R", "tests", "inst") - ) - - # Exclude vignette code from this step here which may be - # located at "inst/doc" (see below) - vignette_files <- list.files( - path = file.path(pkg_path, "inst", "doc"), - pattern = "\\.[Rr]$", - recursive = FALSE, - full.names = FALSE - ) - - # Prepare exclusions - # i.e., a named list of file paths relative to `path` argument and with - # `Inf` as values (see code of `lintr::lint_dir`; as of `lintr` v2.0.1) - files_to_exclude <- c( - if (length(files_not_tolint) > 0) { - file.path(pkg_path, files_not_tolint) - }, - if (length(vignette_files) > 0) { - file.path(pkg_path, "inst", "doc", vignette_files) - } - ) - - excluded_files <- as.list(rep(Inf, length(files_to_exclude))) - names(excluded_files) <- files_to_exclude - - lints1 <- lintr::lint_dir( - path = paths[dir.exists(paths)], - exclusions = excluded_files, - linters = linters_config, - parse_settings = FALSE, - relative_path = FALSE # TRUE assumes that argument path is of length 1 - ) - - - #--- Lint code from vignettes - # (extracted by building the vignette(s) from vignette.Rmd - - # an automatic process which adds an extra trailing blank line) - linters_config[["trailing_blank_lines_linter"]] <- NULL - - # Locate vignette code - # During interactive development located at pkg_path/doc - path_vignette_code <- file.path(pkg_path, "doc") - - if (!dir.exists(path_vignette_code)) { - # During build/check located at pkg_path/inst/doc/ - path_vignette_code <- file.path(pkg_path, "inst", "doc") - } - - - if (dir.exists(path_vignette_code)) { - lints2 <- lintr::lint_dir( - path = path_vignette_code, - linters = linters_config, - parse_settings = FALSE, - relative_path = FALSE # TRUE assumes that argument path is of length 1 - ) - } else { - lints2 <- NULL - } - - has_lints <- c(length(lints1) > 0, length(lints2) > 0) - if (any(has_lints)) { - if (has_lints[1]) print(lints1) - if (has_lints[2]) print(lints2) - stop("Not lint free.") - } - } else { - warning( - "No linting: failed to find package source at ", - shQuote(normalizePath(pkg_path, mustWork = FALSE)) - ) - } -} diff --git a/tests/testthat.R b/tests/testthat.R index ac0ea64..4cbdfe7 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,4 @@ -library("testthat") -library("rSW2exter") +library("testthat") # nolint: undesirable_function_linter +library("rSW2exter") # nolint: undesirable_function_linter test_check("rSW2exter") diff --git a/tests/testthat/test_soils_NRCS_SDA.R b/tests/testthat/test_soils_NRCS_SDA.R index 877d42f..0ff7bc5 100644 --- a/tests/testthat/test_soils_NRCS_SDA.R +++ b/tests/testthat/test_soils_NRCS_SDA.R @@ -5,18 +5,16 @@ test_that("Calculate NRCS organic soil horizons", { taxsubgrp = c("x", "histic", "x", "x", "x", "x", NA), desgnmaster = c("L", "L", "O", "x", "x", "x", NA), texture = c("x", "x", "x", "CE", "x", "x", NA), - lieutex = c("x", "x", "x", "x", "Muck", "x", NA) + lieutex = c("x", "x", "x", "x", "Muck", "x", NA), + stringsAsFactors = FALSE ) - expect_equal( + expect_identical( is_NRCS_horizon_organic(x), c(FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, NA) ) - expect_equal( - is_NRCS_horizon_organic(x[1, , drop = FALSE]), - FALSE - ) + expect_false(is_NRCS_horizon_organic(x[1, , drop = FALSE])) }) @@ -52,14 +50,17 @@ test_that("Calculate NRCS soil depth", { var_soiltexture = var_stxt3 ) - expect_equal(locs_table_depths[1, "N_horizons"], id_sd) - expect_equal(locs_table_depths[1, "SoilDepth_cm"], soildepth) - expect_equal(locs_table_depths[1, 2 + id_sd], soildepth) + expect_equal( + locs_table_depths[1, "N_horizons"], + id_sd, + ignore_attr = c("waldo_opts", "type") + ) + expect_identical(locs_table_depths[1, "SoilDepth_cm"], soildepth) + expect_identical(locs_table_depths[1, 2 + id_sd], soildepth) if (k > 1) { - expect_equal( - locs_table_depths[1, 2 + 1:(id_sd - 1)], - x[1:(id_sd - 1), "layer_depth"], - ignore_attr = TRUE + expect_identical( + unname(locs_table_depths[1, 2 + 1:(id_sd - 1)]), + x[1:(id_sd - 1), "layer_depth"] ) } } @@ -77,7 +78,7 @@ test_that("Extract soils from NRCS SDA", { nrow = 2 ) - mukeys <- c(471168, 1606800) + mukeys <- c(471168L, 1606800L) expected_soil_variables <- c("MUKEY", "COKEY", "Horizon_No") expected_depth_variables <- c("N_horizons", "SoilDepth_cm") @@ -139,27 +140,37 @@ test_that("Extract soils from NRCS SDA", { tmp <- suppressWarnings(fetch_mukeys_spatially_NRCS_SDA(locations)) - expect_equal(tmp[["mukeys"]], mukeys) + expect_identical(tmp[["mukeys"]], mukeys) + + + # Test chunking of `locations` + ids <- rep(seq_len(nrow(locations)), each = 50L) + tmp <- suppressWarnings(fetch_mukeys_spatially_NRCS_SDA( + x = locations[ids, , drop = FALSE], + chunk_size = 10L + )) + expect_identical(tmp[["mukeys"]], mukeys[ids]) + # Example 1: extract soils by mukey values - soils1a <- extract_soils_NRCS_SDA(mukeys = mukeys[1]) + soils1a <- extract_soils_NRCS_SDA(mukeys = mukeys[[1L]]) soils1 <- extract_soils_NRCS_SDA(mukeys = mukeys) for (kelem in expected_obj_results) { - expect_equal(soils1a[[kelem]], soils1[[kelem]][1, , drop = FALSE]) + expect_identical(soils1a[[kelem]], soils1[[kelem]][1L, , drop = FALSE]) } # Example 2: extract soils by geographic location - soils2a <- suppressWarnings(extract_soils_NRCS_SDA(x = locations[1, ])) + soils2a <- suppressWarnings(extract_soils_NRCS_SDA(x = locations[1L, ])) soils2 <- suppressWarnings(extract_soils_NRCS_SDA(x = locations)) for (kelem in expected_obj_results) { - expect_equal(soils2a[[kelem]], soils2[[kelem]][1, , drop = FALSE]) + expect_identical(soils2a[[kelem]], soils2[[kelem]][1L, , drop = FALSE]) } - expect_equal(soils1, soils2) + expect_identical(soils1, soils2) expect_named(soils1, expected_obj_variables) expect_true( rSW2data::check_depth_table( diff --git a/tests/testthat/test_soils_POLARIS.R b/tests/testthat/test_soils_POLARIS.R index 2c1429b..46d8baa 100644 --- a/tests/testthat/test_soils_POLARIS.R +++ b/tests/testthat/test_soils_POLARIS.R @@ -5,13 +5,13 @@ test_that("Extract soils from POLARIS", { skip_if_offline() - path_polaris <- "../test_data/polaris_example" + path_polaris <- file.path("..", "test_data", "polaris_example") vars <- c("bd", "sand", "clay", "silt") stat <- "mean" ## Check that we have POLARIS data has_POLARIS <- isTRUE(all( - check_POLARIS(path = path_polaris, vars = vars, stat = stat) + check_POLARIS(path = path_polaris, vars = vars, stats = stat) )) if (has_POLARIS) { diff --git a/tests/testthat/test_topography.R b/tests/testthat/test_topography.R index ce3b134..ba3b7be 100644 --- a/tests/testthat/test_topography.R +++ b/tests/testthat/test_topography.R @@ -19,28 +19,26 @@ test_that("Extract from NED USA", { to_class = "sf", crs = 4326 ) - extent_polygon <- FedData::polygon_from_extent( - x = 1.1 * raster::extent(locations), - proj4string = "+init=epsg:4326" + extent_polygon <- terra::vect( + 1.1 * terra::ext(locations), + crs = terra::crs(locations) ) ### Download NED - ned_1s_example <- FedData::get_ned( + ned_1s_example <- suppressMessages(FedData::get_ned( template = extent_polygon, label = label_ned, res = 1, extraction.dir = path_ned - ) + )) ### Derive slope and aspect for (opt in c("slope", "aspect")) { - tmp <- raster::terrain( + tmp <- terra::terrain( x = ned_1s_example, - opt = opt, + v = opt, unit = "degrees", - filename = filenames_ned_examples[[opt]], - datatype = "FLT4S", - options = c("COMPRESS=DEFLATE", "ZLEVEL=9", "INTERLEAVE=BAND") + filename = filenames_ned_examples[[opt]] ) } @@ -55,20 +53,17 @@ test_that("Extract from NED USA", { #--- Expectations - expect_equal(nrow(vals_topo), nrow(locations)) - expect_equal(ncol(vals_topo), 3L) - expect_equal(colnames(vals_topo), c("elev", "slope", "aspect")) - expect_type(vals_topo, "double") + expect_identical(nrow(vals_topo), nrow(locations)) + expect_identical(ncol(vals_topo), 3L) + expect_identical(colnames(vals_topo), c("elev", "slope", "aspect")) + expect_type(as.matrix(vals_topo), "double") expect_true( all( - is.na(vals_topo[, "slope"]) | (vals_topo[, "slope"] >= 0 & vals_topo[, "slope"] <= 90) ) ) expect_true( all( - is.na(vals_topo[, "aspect"]) | - vals_topo[, "aspect"] == 999 | (vals_topo[, "aspect"] >= -180 & vals_topo[, "aspect"] <= 180) ) ) diff --git a/tools/extract_soils_NRCS_gNATSGO.R b/tools/extract_soils_NRCS_gNATSGO.R index ab167b5..428e1e2 100644 --- a/tools/extract_soils_NRCS_gNATSGO.R +++ b/tools/extract_soils_NRCS_gNATSGO.R @@ -455,10 +455,11 @@ extract_soils_NRCS_gNATSGO <- function( ids <- match(locs_keys[, "cokey"], rownames(tmp_texture), nomatch = NA) locs_table_texture <- tmp_texture[ids, ] - tmp <- strsplit(colnames(locs_table_texture), split = "_") - colnames(locs_table_texture) <- sapply( + tmp <- strsplit(colnames(locs_table_texture), split = "_", fixed = TRUE) + colnames(locs_table_texture) <- vapply( X = tmp, - FUN = function(x) paste0(x[2], "_L", x[1]) + FUN = function(x) paste0(x[[2L]], "_L", x[[1L]]), + FUN.VALUE = NA_character_ )