From 0f905a08ae2ac51cabb1c6721259d6cb10f98a5a Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Mon, 22 Apr 2024 10:29:35 -0700 Subject: [PATCH] simplifyFragmentData/simplifyArtifactData: refactor "all records missing" volume for better efficiency --- NEWS.md | 3 ++- R/simplifyArtifactData.R | 13 +++++-------- R/simplifyFragmentData.R | 11 ++++------- 3 files changed, 11 insertions(+), 16 deletions(-) diff --git a/NEWS.md b/NEWS.md index d8932455..9001c3c9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -12,7 +12,8 @@ - `get_soilseries_from_NASIS()`: replace `areasymbol` column to use relationship-style name `"soilseries_typelocst"` (minor breaking change) - `fetchSDA_spatial()`: Add support for querying mapunit point (`"mupoint"`), mapunit line (`"muline"`), special feature point (`"featpoint"`), special feature line (`"featline"`) by `mukey` or `featkey`, geometry type selectable via `geom.src` argument - `SDA_spatialQuery()`: Add support for querying mapunit point (`"mupoint"`), mapunit line (`"muline"`), special feature point (`"featpoint"`), special feature line (`"featline"`) for a spatial extent, geometry type selectable via `what` argument - + - `simplifyFragmentData()` / `simplifyArtifactData()` efficiency improvement when all records are missing data + # soilDB 2.8.1 (2024-01-09) - `get_mapunit_from_NASIS()`, `get_lmuaoverlap_from_NASIS()` and `get_legend_from_NASIS()` gain `areatypename` argument used for filtering legends by `areatypename`. diff --git a/R/simplifyArtifactData.R b/R/simplifyArtifactData.R index 3c33a4da..eca61996 100644 --- a/R/simplifyArtifactData.R +++ b/R/simplifyArtifactData.R @@ -50,18 +50,15 @@ simplifyArtifactData <- function(art, id.var, vol.var = "huartvol", nullFragsAre # artifact size classes, using fragment breaks, are used in this function art.classes <- c('art_fgr', 'art_gr', 'art_cb', 'art_st', 'art_by', 'art_ch', 'art_fl', 'art_unspecified') result.columns <- c(id.var, art.classes, "total_art_pct", "huartvol_cohesive", "huartvol_penetrable", "huartvol_innocuous", "huartvol_persistent") - - # warn the user and remove the NA records - # if all fragvol are NA then rf is an empty data.frame and we are done + # warn the user and remove the NA records + # if all huartvol are NA then result is a data frame with all ID values NA if (nrow(art[which(!is.na(art[[vol.var]])),]) == 0) { message('NOTE: all records are missing artifact volume') - dat <- as.data.frame(t(rep(NA, length(result.columns)))) - for (i in 1:length(art[[id.var]])) { - dat[i, ] <- dat[1, ] - dat[i, which(result.columns == id.var)] <- art[[id.var]][i] - } + dat <- as.data.frame(t(rep(NA, length(result.columns))))[seq_len(length(art[[id.var]])),] + dat[[which(result.columns == id.var)]] <- art[[id.var]] colnames(dat) <- result.columns + rownames(dat) <- NULL return(dat) } else if (any(is.na(art[[vol.var]]))) { art <- art[which(!is.na(art[[vol.var]])), ] diff --git a/R/simplifyFragmentData.R b/R/simplifyFragmentData.R index b17b979c..25b426a5 100644 --- a/R/simplifyFragmentData.R +++ b/R/simplifyFragmentData.R @@ -166,16 +166,13 @@ simplifyFragmentData <- function(rf, id.var, vol.var = "fragvol", prefix = "frag result.columns <- c(id.var, frag.classes, "total_frags_pct", "total_frags_pct_nopf") # warn the user and remove the NA records - - # if all fragvol are NA then rf is an empty data.frame and we are done + # if all fragvol are NA then result is a data frame with all ID values NA if (nrow(rf[which(!is.na(rf[[vol.var]])),]) == 0) { message(sprintf('NOTE: all records are missing %s', msg)) - dat <- as.data.frame(t(rep(NA, length(result.columns)))) - for (i in 1:length(rf[[id.var]])) { - dat[i,] <- dat[1,] - dat[i,which(result.columns == id.var)] <- rf[[id.var]][i] - } + dat <- as.data.frame(t(rep(NA, length(result.columns))))[seq_len(length(rf[[id.var]])),] + dat[[which(result.columns == id.var)]] <- rf[[id.var]] colnames(dat) <- result.columns + rownames(dat) <- NULL return(dat) } else if (any(is.na(rf[[vol.var]]))) { rf <- rf[which(!is.na(rf[[vol.var]])), ]