Merge pull request #18 from FRDC-SHL/dev

# LITAP 0.6.0
- Import x/y coords or create them if they don't exist
- flow_mapper() now requires grid or infers from x/y value of input files
   - form_mapper() and wepp_mapper() now use grid inferred from x/y value of 
     flow_mapper() output files
- flow_mapper() now has upslope_m (upslope cells * grid^2)
- flow_mapper() calculates UCED
- facet_mapper() calculates buffer edges
- Simplify output with 'debug' argument (if false, removes intermediate files)
- Simplify output columns by removing intermediate ones
- Remove option to 'end' a run prematurely (required due to simplified output)
- Remove dbf output option because it truncates column names
- Fix flow_mapper() inconsistencies
- Add extra data output "topographical_derivatives" in facet_mapper
- Initial work on all_points data output

Author: steffilazerte

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

@@ -14,65 +14,30 @@ jobs:
       fail-fast: false
       matrix:
         config:
+          - {os: macOS-latest,   r: 'release'}
           - {os: windows-latest, r: 'release'}
-          - {os: macOS-latest, r: 'release'}
-          - {os: ubuntu-latest, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
-          - {os: ubuntu-latest, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
+          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+          - {os: ubuntu-latest,   r: 'oldrel-1'}
 
     env:
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      RSPM: ${{ matrix.config.rspm }}
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
 
     steps:
       - uses: actions/checkout@v2
 
-      - uses: r-lib/actions/setup-r@v1
+      - 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-pandoc@v1
+      - uses: r-lib/actions/setup-pandoc@v2
 
-      - 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
-        if: runner.os != 'Windows'
-        uses: actions/cache@v2
+      - uses: r-lib/actions/setup-r-dependencies@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}
+          extra-packages: any::rcmdcheck
+          needs: check
 
-      - 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
+      - uses: r-lib/actions/check-r-package@v2

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: LITAP
 Type: Package
 Title: Landscape Integrated Terrain Analysis Package
-Version: 0.5.0
+Version: 0.6.0
 Authors@R: c(
      person("Steffi", "LaZerte", email = "sel@steffilazerte.ca", role = c("aut","cre")),
      person("Sheng", "Li", email = "sheng.li@canada.ca", role = "aut"),
@@ -34,15 +34,17 @@ Imports:
     stringr (>= 1.2.0),
     tibble (>= 2.1.3),
     tidyselect (>= 1.1.0),
-    tidyr (>= 1.0.0)
+    tidyr (>= 1.0.0),
+    writexl (>= 1.4.0)
 Suggests: 
+    gt (>= 0.3.1),
     foreign (>= 0.8.67),
     knitr,
     microbenchmark,
     readxl,
     rgdal,
     testthat (>= 3.0.0)
 VignetteBuilder: knitr
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 Roxygen: list(markdown = TRUE)
 Config/testthat/edition: 3

NAMESPACE

@@ -6,7 +6,7 @@ export(flow_mapper)
 export(flow_plot)
 export(form_mapper)
 export(load_file)
-export(merge_flow_form)
 export(slope_gc)
 export(wepp_mapper)
 importFrom(magrittr,"%>%")
+importFrom(magrittr,"%T>%")

NEWS.md

@@ -1,3 +1,19 @@
+# LITAP 0.6.0
+- Import x/y coords or create them if they don't exist
+- flow_mapper() now requires grid or infers from x/y value of input files
+   - form_mapper() and wepp_mapper() now use grid inferred from x/y value of 
+     flow_mapper() output files
+- flow_mapper() now has upslope_m (upslope cells * grid^2)
+- flow_mapper() calculates UCED
+- facet_mapper() calculates buffer edges
+- Simplify output with 'debug' argument (if false, removes intermediate files)
+- Simplify output columns by removing intermediate ones
+- Remove option to 'end' a run prematurely (required due to simplified output)
+- Remove dbf output option because it truncates column names
+- Fix flow_mapper() inconsistencies
+- Add extra data output "topographical_derivatives" in facet_mapper
+- Initial work on all_points data output
+
 # LITAP 0.5.0
 - Load files forces to numeric (fixes problems where some imports in character)
 - Corrected `slope_gc()` directions (fixes #10)

R/LITAP_combine_files.R

@@ -0,0 +1,52 @@
+#' Combine flow and form output dems
+#'
+#' `flow_mapper()` and `form_mapper()` each provide output information per cell
+#' of a dem file. This function takes the fill dem from `flow_mapper()` as well
+#' as the length and weti dem files from `form_mapper()` and merges them
+#' together into a complete dem file with all information. This file is saved
+#' to the project folder.
+#'
+#' @param folder Character. Folder with previous LITAP runs (i.e. where output
+#'   of `flow_mapper()` etc. are)
+#' @param out_format Character. Output format (rds or csv) that merged file
+#'   should be saved as (if different from the rest; by default uses the format
+#'   of the other LITAP output files)
+
+merge_all <- function(folder, out_format = NULL) {
+
+  # Get current out format
+  ext <- get_format(folder, where = "flow")
+  if(!is.null(out_format)) {
+    check_out_format(out_format)
+    ext <- out_format
+  }
+
+  flow <- get_previous(folder, step = "fill", where = "flow") %>%
+    dplyr::select(-"ridge")
+
+  flow_stats <- get_previous(folder, step = "fill", where = "flow", type = "stats")
+
+  inv <- get_previous(folder, step = "inverted", where = "flow") %>%
+    dplyr::select("seqno", "ddir", "drec", "upslope", "upslope_m",
+                  "inv_initial_shed", "inv_local_shed", "edge_map") %>%
+    dplyr::rename_with(.cols = -c("seqno", dplyr::contains("inv_")),
+                       ~paste0("inv_", .))
+  inv_stats <- get_previous(folder, step = "inverted", where = "flow", type = "stats")
+
+  length <- get_previous(folder, step = "length", where = "form")
+
+  weti <- get_previous(folder, step = "form", where = "form")
+
+  combo <- dplyr::left_join(flow, inv, by = "seqno") %>%
+    dplyr::left_join(length,
+                     by = c("seqno", "x", "y", "row", "col", "elev")) %>%
+    dplyr::left_join(weti,
+                     by = c("seqno", "x", "y", "row", "col",
+                            "elev", "drec", "upslope"))
+
+  name <- paste0("all_points.", ext)
+  if(ext == "rds") readr::write_rds(combo, file.path(folder, name))
+  if(ext == "csv") readr::write_csv(combo, file.path(folder, name), progress = FALSE)
+  combo
+}
+

R/LITAP_common_docs.R

@@ -1,16 +1,18 @@
 # args ------------------
-#' Common arguments for [flow_mapper()] and [form_mapper()]
+
+#' Common arguments for [flow_mapper()], [form_mapper()], [facet_mapper()], a
+#' nd [wepp_mapper()]
 #'
+#' @param grid Numeric. Grid size in m of the input DEM file
 #' @param resume Character. From which stage should the run be resumed? (see
-#'   Details below)
-#' @param end Character. If ending a run after a particular step, which step
-#'   (see Details below)
 #' @param clean Logical. Remove all output files from previous runs in this
 #'   folder?
 #' @param report Logical. Create html report of results?
 #' @param log Logical. Create log file recording progress?
 #' @param verbose Logical. Output extra progress messages.
 #' @param quiet Logical. Suppress all messages.
+#' @param debug Logical. If TRUE, output files contain intermediate columns
+#'   useful for debugging (e.g., 'buffer', 'seqno_buffer', etc.) Default FALSE.
 #'
 #' @keywords internal
 #' @name args

R/LITAP_load.R

@@ -20,7 +20,8 @@
 #' @param clim Vector. Two numbers specifying the start and end of a subset of
 #'   columns to extract
 #' @param edge Logical. Whether to add an edge (buffer) around the data.
-#' @param verbose Logical. Output extra progress messages.
+#'
+#' @inheritParams args
 #'
 #' @return Returns a data frame containing elevation data in a format suitable
 #'   for analysis
@@ -65,7 +66,8 @@
 #'
 #' @export
 load_file <- function(file, nrow = NULL, ncol = NULL, missing_value = -9999,
-                      rlim = NULL, clim = NULL, edge = TRUE, verbose = TRUE) {
+                      rlim = NULL, clim = NULL, grid = NULL, edge = TRUE,
+                      verbose = TRUE) {
 
   if(!file.exists(file)) stop("Cannot locate ", file,
                               " relative to working directory, ", getwd(),
@@ -90,17 +92,17 @@ load_file <- function(file, nrow = NULL, ncol = NULL, missing_value = -9999,
     db <- dplyr::arrange(db, dplyr::desc(y), x)
     nrow <- length(unique(db$y))
     ncol <- length(unique(db$x))
-    db <- dplyr::select(db, -"x", -"y")
     if(verbose) message("  Detected ", nrow, " rows and ", ncol, " columns")
   } else if(!is.null(nrow) && !is.null(ncol)) {
     if(verbose) message("  Using supplied ", nrow, " rows and ", ncol, " columns")
   } else {
-    stop("dbf files with only one column require nrow and ncol arguments.",
+    stop("dbf files with only one column require 'nrow' and 'ncol' arguments.",
          call. = FALSE)
   }
 
-  db_format(db, nrow, ncol, missing_value, verbose) %>%
-    db_prep(clim, rlim, edge, verbose)
+  db_format(db, nrow = nrow, ncol = ncol, grid = grid,
+            missing_value = missing_value, verbose = verbose) %>%
+    db_prep(clim = clim, rlim = rlim, edge = edge, verbose = verbose)
 }
 
 
@@ -185,21 +187,33 @@ load_raster <- function(file) {
   db
 }
 
-db_format <- function(db, nrow, ncol, missing_value = -9999, verbose) {
+db_format <- function(db, nrow, ncol, grid, missing_value = -9999, verbose) {
   if(verbose) message("  Formating grid")
   # Check if valid rows/cols
   if(nrow * ncol != length(db$elev)){
     stop("Number of rows and columns does not match the total number of cells in the data base, Try again!")
   }
 
   # Arrange as grid
-  db %>%
+  db <- db %>%
     dplyr::mutate(seqno = 1:length(elev),
                   row = sort(rep(1:nrow, length(elev)/nrow)),
                   col = rep(1:ncol, length(elev)/ncol),
                   missing = elev == missing_value,
                   elev = replace(elev, missing, NA_real_)) %>%
     dplyr::mutate(dplyr::across(-"missing", as.numeric))
+
+  if(any(!c("x", "y") %in% names(db))) {
+    if(is.null(grid)) stop("No grid dimensions in data, require 'grid' argument",
+                           call. = FALSE)
+    if(verbose) message("  No x/y in file, creating x/y from cols/rows/grid")
+
+    db <- dplyr::mutate(db,
+                        x = col * grid,
+                        y = rev(row) * grid)
+  }
+
+  db
 }
 
 db_prep <- function(db, clim, rlim, edge, verbose) {
@@ -356,3 +370,18 @@ format_rule <- function(rule, type, quiet) {
 seqno_to_buffer <- function(seqno, seqno_buffer) {
   seqno_buffer[seqno]
 }
+
+seqno_as_buffer <- function(seqno, db) {
+  dplyr::mutate(db, seqno2 = seqno) %>%
+    add_buffer() %>%
+    dplyr::filter(.data$seqno2 == !!seqno) %>%
+    dplyr::pull(.data$seqno)
+}
+
+seqno_from_buffer <- function(seqno_buffer, db) {
+  dplyr::mutate(db, seqno2 = seqno) %>%
+    add_buffer() %>%
+    dplyr::filter(.data$seqno == !!seqno_buffer) %>%
+    dplyr::pull(.data$seqno2)
+}
+

R/utils_plot.R R/LITAP_plot.RR/utils_plot.R renamed to R/LITAP_plot.R

@@ -12,8 +12,8 @@
 #' @param shed Logical. Show watersheds?
 #' @param pits Logical. Show watershed pits (lowest point)
 #' @param shed_type Character. Which type of watershed, must be included as a
-#'   column in the data frame. Can be one of 'initial', 'local', 'pond', or
-#'   'fill'.
+#'   column in the data frame. Can be one of 'initial', 'local', 'fill',
+#'   'inv_initial', or 'inv_local'/'inverted'.
 #' @param upslope_threshold Numeric. If dir = TRUE, only show flow directions
 #'   for cells with >= this many cells which drain to it.
 #' @param cells Vector. Which cells to show
@@ -25,7 +25,7 @@
 #'
 #' @export
 flow_plot <- function(db, type = "relief", dir = FALSE, seqno = FALSE, highlight = FALSE,
-                      shed = FALSE, shed_type = "shedno", pits = FALSE,
+                      shed = FALSE, shed_type = "local", pits = FALSE,
                       upslope_threshold = NULL,
                       cells = NULL, clim = NULL, rlim = NULL,
                       stats = NULL, missing = NA) {
@@ -58,8 +58,10 @@ flow_plot <- function(db, type = "relief", dir = FALSE, seqno = FALSE, highlight
   if(shed == TRUE){
     if(shed_type == "initial" & "initial_shed" %in% names(db)) db$shedno <- db$initial_shed
     if(shed_type == "local" & "local_shed" %in% names(db)) db$shedno <- db$local_shed
-    if(shed_type == "pond" & "pond_shed" %in% names(db)) db$shedno <- db$pond_shed
+    #if(shed_type == "pond" & "pond_shed" %in% names(db)) db$shedno <- db$pond_shed
     if(shed_type == "fill" & "fill_shed" %in% names(db)) db$shedno <- db$fill_shed
+    if(shed_type == "inv_initial" & "inv_initial_shed" %in% names(db)) db$shedno <- db$inv_initial_shed
+    if(shed_type %in% c("inv_local", "inverted") & "inv_local_shed" %in% names(db)) db$shedno <- db$inv_local_shed
   }
 
 
@@ -98,12 +100,12 @@ flow_plot <- function(db, type = "relief", dir = FALSE, seqno = FALSE, highlight
 
     g <- g +
       ggplot2::geom_raster(ggplot2::aes(fill = factor(shedno))) +
-      ggplot2::scale_fill_discrete(name = "Watershed", guide = FALSE) +
+      ggplot2::scale_fill_discrete(name = "Watershed", guide = "none") +
       ggplot2::geom_text(data = labs, ggplot2::aes(label = shedno))
 
   } else if(type == "relief") {
     g <- g + ggplot2::geom_raster(ggplot2::aes(alpha = relief)) +
-      ggplot2::scale_alpha_continuous(range = c(1, 0), guide = FALSE)
+      ggplot2::scale_alpha_continuous(range = c(1, 0), guide = "none")
   } else if(type == "elevation") {
     g <- g + ggplot2::geom_raster(ggplot2::aes(alpha = elev)) +
       ggplot2::scale_alpha_continuous(range = c(0, 1))