Merge pull request #467 from ncss-tech/fix-466

fix: fetchGDB when WHERE is NULL

Author: brownag

R/get_component_from_GDB.R

@@ -325,7 +325,7 @@ get_mapunit_from_GDB <- function(dsn = "gNATSGO_CONUS.gdb",
     }
   )
   pmg <- sf::read_sf(dsn = dsn, query = qry, as_tibble = FALSE, fid_column_name = "copmgrpkey")
-  
+  pmg$copmgrpkey.1 <- NULL
 
   # remove duplicate rvindicators
   dat <- as.data.frame.matrix(table(pmg$cokey, pmg$rvindicator))
@@ -647,6 +647,12 @@ fetchGDB <- function(dsn = "gNATSGO_CONUS.gdb",
     stop("package 'aqp' is required", call. = FALSE)
   }
 
+  stopifnot(length(WHERE) <= 1)
+  whr <- WHERE
+  if (is.null(whr)) {
+    whr <- basename(dsn)
+  }
+  
   # checks
   vars_le <- vars_le <- sf::read_sf(dsn = dsn, query = "SELECT * FROM legend LIMIT 0", as_tibble = FALSE, fid_column_name = "lkey") |> names() |> paste(collapse = "|")
 
@@ -703,7 +709,7 @@ fetchGDB <- function(dsn = "gNATSGO_CONUS.gdb",
       if (idx_le) {
         message("getting components and horizons from areasymbol = '", unique(x$idx), "'")
       } else{
-        message("getting components and horizons from ", WHERE)
+        message("getting components and horizons from ", whr)
       }
 
       # components
@@ -744,7 +750,7 @@ fetchGDB <- function(dsn = "gNATSGO_CONUS.gdb",
 
   if (idx_co || is.null(WHERE)) {
 
-    message("getting components and horizons from ", WHERE)
+    message("getting components and horizons from ", whr)
 
     # target component table ----
     co <- get_component_from_GDB(
@@ -766,8 +772,14 @@ fetchGDB <- function(dsn = "gNATSGO_CONUS.gdb",
                                 childs = childs)
   }
 
-  le$lkey.1  <- NULL
-  mu$mukey.1 <- NULL
+  if (idx_le) {
+    le$lkey.1  <- NULL
+  }
+  
+  if (idx_mu) {
+    mu$mukey.1 <- NULL
+  }
+  
   co$cokey.1 <- NULL
   h$chkey.1  <- NULL
 

tests/testthat/test-fetchGDB.R

@@ -0,0 +1,26 @@
+test_that("fetchGDB works", {
+  
+  skip_on_cran()
+  
+  skip_if_not_installed("aqp")
+  
+  skip_if_not_installed("soilDBdata")
+  
+  f <- system.file("extdata", "manual", "gSSURGO_MH_FY26.zip", package = "soilDBdata")
+  
+  skip_if_not(nzchar(f))
+  
+  dsn <- paste0("/vsizip/{", f, "}/gSSURGO_MH.gdb")
+  
+  # default behavior
+  res <- suppressWarnings(fetchGDB(dsn))
+  expect_true(inherits(res, 'SoilProfileCollection'))
+  
+  # include child tables
+  res <- suppressWarnings(fetchGDB(dsn, childs = TRUE))
+  expect_true(inherits(res, 'SoilProfileCollection'))
+  
+  # trigger legend-level iteration
+  res <- suppressWarnings(fetchGDB(dsn, WHERE = "legend.areasymbol = legend.areasymbol"))
+  expect_true(inherits(res, 'SoilProfileCollection'))
+})