Merge branch 'master' into WRB2022

Author: brownag

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

@@ -26,21 +26,21 @@ jobs:
           - {os: macOS-latest, r: 'release'}
           - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
           - {os: ubuntu-22.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/jammy/latest"}
-          - {os: ubuntu-20.04, r: '3.5',  rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
+          - {os: ubuntu-20.04, r: '3.6',  rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
 
     env:
       R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
       RSPM: ${{ matrix.config.rspm }}
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
 
-      - uses: r-lib/actions/setup-pandoc@v1
+      - uses: r-lib/actions/setup-pandoc@v2
 
       - name: Query dependencies
         run: |

DESCRIPTION

@@ -3,7 +3,7 @@ Title: A System of Soil Classification for Making and Interpreting Soil Surveys
 Description: Taxonomic dictionaries, formative element lists, and functions related to the maintenance, development and application of U.S. Soil Taxonomy. 
    Data and functionality are based on official U.S. Department of Agriculture sources including the latest edition of the Keys to Soil Taxonomy. Descriptions and metadata are obtained from the National Soil Information System or Soil Survey Geographic databases. Other sources are referenced in the data documentation. 
    Provides tools for understanding and interacting with concepts in the U.S. Soil Taxonomic System. Most of the current utilities are for working with taxonomic concepts at the "higher" taxonomic levels: Order, Suborder, Great Group, and Subgroup.
-Version: 0.2.3
+Version: 0.2.5
 Authors@R: c(person(given="Andrew", family="Brown", email="[email protected]", role = c("aut", "cre")), person(given="Dylan", family="Beaudette", role = c("aut"), email = "[email protected]"))
 Maintainer: Andrew Brown <[email protected]>
 Depends: R (>= 3.5)

NAMESPACE

@@ -42,4 +42,5 @@ importFrom(stringr,fixed)
 importFrom(stringr,str_locate)
 importFrom(stringr,str_locate_all)
 importFrom(utils,browseURL)
+importFrom(utils,tail)
 importFrom(utils,type.convert)

NEWS.md

@@ -1,3 +1,8 @@
+# SoilTaxonomy 0.2.4 (2023-11-16)
+ - `taxonTree()` default markup via `special.chars` argument emulates `fs::dir_tree()` output
+ - `parse_family()` now returns more complete information for taxa above family
+   - `taxminalogy` column for taxa with strongly contrasting control sections now use `" over "` as the separator between class names. 
+   
 # SoilTaxonomy 0.2.3 (2023-02-01)
  - Fix unintended case-sensitivity of `FormativeElements()`; thanks to Shawn Salley (@swsalley)
  - Fix for `extractSMR()` via fix for `FormativeElements()` applied at multiple levels (affects taxa above subgroup level)

R/explainST.R

@@ -1,4 +1,4 @@
-#' Explain a taxon name using formative elements
+#' @title Explain a taxon name using formative elements
 #'
 #' @param x a Subgroup, Great Group, Suborder or Order-level taxonomic name; matching is exact and case-insensitive
 #' @param format output format: 'text' | 'html'
@@ -27,9 +27,16 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
   x.lvl <- taxon_to_level(x)
 
   # no-match NULL data object
-  empty <- list(defs = data.frame(element = "", derivation = "", 
-                                  connotation = "", simplified = NA, link = NA), 
-                char.index = 0)
+  empty <- list(
+    defs = data.frame(
+      element = "", 
+      derivation = "",
+      connotation = "", 
+      simplified = NA, 
+      link = NA
+    ), 
+    char.index = 0
+  )
 
   if (!is.na(x.lvl) && x.lvl == "order") {
     # handle input of full order name e.g. "aridisols"
@@ -63,11 +70,11 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
   } else {
     x.sg <- empty
   }
-   
+  
   # TODO: family classes
 
-  newline <- switch(format, text='\n', html='<br>')
-  whitespace <- switch(format, text=' ', html='&nbsp;')
+  newline <- switch(format, text = '\n', html = '<br>')
+  whitespace <- switch(format, text = ' ', html = '&nbsp;')
 
   main.style <- 'font-size: 85%; font-weight: bold;'
   sub.style <- 'font-size: 85%; font-style: italic;'
@@ -81,10 +88,10 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
   if(format == 'html') {
     #
     x.txt <- paste0('<html><div style="padding: 5px; font-family: monospace; border: 1px solid grey; border-radius: 5px;">',
-                   '<span style="', main.style, '">',
-                   x,
-                   '</span>'
-                   )
+                    '<span style="', main.style, '">',
+                    x,
+                    '</span>'
+    )
 
     sg.txt <- paste0('<span style="', sub.style, '">', sg.l, '</span>')
     gg.txt <-  paste0('<span style="', sub.style, '">', gg.l, '</span>')
@@ -105,16 +112,16 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
   # the taxon to explain, usually a subgroup
   ex <- append(ex, x.txt) 
 
-  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ",sg.l[[2]])))
+  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ", sg.l[[2]])))
     ex <- append(ex, sg.txt)
 
-  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ",gg.l[[2]])))
+  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ", gg.l[[2]])))
     ex <- append(ex, gg.txt)
 
-  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ",so.l[[2]])))
+  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ", so.l[[2]])))
     ex <- append(ex, so.txt)
 
-  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ",o.l[[2]])))
+  if (grepl("[A-Za-z?]", gsub("&nbsp;"," ", o.l[[2]])))
     ex <- append(ex, o.txt)
 
   if(format == 'html') {
@@ -126,13 +133,13 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
   ex.char <- unlist(ex, recursive = TRUE)
 
   # collapse to single character
-  res <- paste(ex.char, collapse=newline)
+  res <- paste(ex.char, collapse = newline)
 
   # put HTML output into viewer
   if(format == 'html' && viewer) {
     viewer <- getOption("viewer", default = utils::browseURL)
-    tf <- tempfile(fileext=".html")
-    cat(res, file=tf)
+    tf <- tempfile(fileext = ".html")
+    cat(res, file = tf)
     viewer(tf)
   }
 
@@ -147,7 +154,7 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
 
 ## TODO: wrap-text with newline if > width
 
-.printExplanation <- function(pos, txt, width=100, ws.char=' ') {
+.printExplanation <- function(pos, txt, width = 100, ws.char = ' ') {
 
   # convert factor to character if txt is factor
   txt <- as.character(txt)
@@ -156,53 +163,53 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
     # split explanation into a vector
     txt <- strsplit(txt, split = '')[[1]]
     # placement of explanation
-    idx <- seq(from=pos, to=pos + (length(txt) - 1))
+    idx <- seq(from = pos, to = pos + (length(txt) - 1))
     # init whitespace, making room for very long explanation
-    ws <- rep(ws.char, times=pmax(width, max(idx)))
+    ws <- rep(ws.char, times = pmax(width, max(idx)))
     # insert text
     ws[idx] <- txt
   } else {
     return("")
   }
   # convert to character
-  return(paste(ws, collapse=''))
+  return(paste(ws, collapse = ''))
 }
 
-.makeBars <- function(width=100, pos, ws.char=' ') {
+.makeBars <- function(width = 100, pos, ws.char = ' ') {
   # init whitespace
-  ws <- rep(ws.char, times=width)
+  ws <- rep(ws.char, times = width)
   # insert bars
   ws[pos] <- '|'
 
   # convert to character
-  return(paste(ws, collapse=''))
+  return(paste(ws, collapse = ''))
 }
 
 
 
 .soilOrderLines <- function(o, ws) {
   txt <- list()
 
-  txt[[1]] <- .makeBars(pos=o$char.index, ws.char=ws)
-  txt[[2]] <- .printExplanation(pos = o$char.index, txt = o$defs$connotation, ws.char=ws)
+  txt[[1]] <- .makeBars(pos = o$char.index, ws.char = ws)
+  txt[[2]] <- .printExplanation(pos = o$char.index, txt = o$defs$connotation, ws.char = ws)
 
   return(txt)
 }
 
 .subOrderLines <- function(o, so, ws) {
   txt <- list()
 
-  txt[[1]] <- .makeBars(pos=c(so$char.index, o$char.index), ws.char=ws)
-  txt[[2]] <- .printExplanation(pos = so$char.index, txt = so$defs$connotation, ws.char=ws)
+  txt[[1]] <- .makeBars(pos = c(so$char.index, o$char.index), ws.char = ws)
+  txt[[2]] <- .printExplanation(pos = so$char.index, txt = so$defs$connotation, ws.char = ws)
 
   return(txt)
 }
 
 .greatGroupLines <- function(o, so, gg, ws) {
   txt <- list()
 
-  txt[[1]] <- .makeBars(pos=c(gg$char.index, so$char.index, o$char.index), ws.char=ws)
-  txt[[2]] <- .printExplanation(pos = gg$char.index, txt = gg$defs$connotation, ws.char=ws)
+  txt[[1]] <- .makeBars(pos = c(gg$char.index, so$char.index, o$char.index), ws.char = ws)
+  txt[[2]] <- .printExplanation(pos = gg$char.index, txt = gg$defs$connotation, ws.char = ws)
 
   return(txt)
 }
@@ -230,8 +237,8 @@ explainST <- function(x, format = c('text', 'html'), viewer = TRUE) {
   while(i < length(sg.pos)+1) {
 
     # add all bars
-    txt[[j]] <- .makeBars(pos=c(sg.pos.temp, gg$char.index, so$char.index, o$char.index), ws.char=ws)
-    txt[[j+1]] <- .printExplanation(pos = sg.pos.temp[1], txt = sg.defs[1], ws.char=ws)
+    txt[[j]] <- .makeBars(pos = c(sg.pos.temp, gg$char.index, so$char.index, o$char.index), ws.char = ws)
+    txt[[j+1]] <- .printExplanation(pos = sg.pos.temp[1], txt = sg.defs[1], ws.char = ws)
 
     # nibble vectors
     sg.pos.temp <- sg.pos.temp[-1]

R/family-classes.R

@@ -30,7 +30,7 @@ parse_family <- function(family, column_metadata = TRUE, flat = TRUE) {
   # load local copy of taxon code lookup table
   load(system.file("data/ST_unique_list.rda", package = "SoilTaxonomy")[1])
 
-  lut <- ST_unique_list[["subgroup"]]
+  lut <- do.call('c', ST_unique_list)
 
   # lookup table sorted from largest to smallest (most specific to least)
   lut <- lut[order(nchar(lut), decreasing = TRUE)]
@@ -40,13 +40,16 @@ parse_family <- function(family, column_metadata = TRUE, flat = TRUE) {
   subgroup.idx <- sapply(res, function(x) which(!is.na(x[,1]))[1])
   subgroup.pos <- sapply(seq_along(subgroup.idx), function(i) res[[i]][subgroup.idx[i], 'start'])
 
-  subgroups <- lut[subgroup.idx]
+  taxname <- lut[subgroup.idx]
+  lowest_level <- taxon_to_level(taxname)
   family_classes <- trimws(substr(family, 0, subgroup.pos - 1))
-
+  taxon_codes <- taxon_to_taxon_code(taxname)
   res <- data.frame(row.names = NULL, stringsAsFactors = FALSE,
-    family = family,
-    subgroup = subgroups,
-    subgroup_code = taxon_to_taxon_code(subgroups),
+    family = ifelse(nchar(family_classes) > 0, family, NA_character_),
+    taxclname = family,
+    taxonname = taxname,
+    subgroup_code = ifelse(lowest_level == "subgroup", taxon_codes, NA_character_),
+    code = taxon_codes,
     class_string = family_classes,
     classes_split = I(lapply(strsplit(family_classes, ","), trimws)))
 
@@ -56,7 +59,7 @@ parse_family <- function(family, column_metadata = TRUE, flat = TRUE) {
 }
 
 #' @import data.table
-#' @importFrom utils type.convert
+#' @importFrom utils type.convert tail
 #' @importFrom stats setNames na.omit
 .get_family_differentiae <- function(res, flat = TRUE) {
 
@@ -125,10 +128,14 @@ parse_family <- function(family, column_metadata = TRUE, flat = TRUE) {
     )
   })
 
-  taxsub <- as.data.frame(do.call('rbind', lapply(decompose_taxon_code(res$subgroup_code), function(x) taxon_code_to_taxon(as.character(rev(x))))),
-                          stringsAsFactors = FALSE)
-  colnames(taxsub) <- rev(c("taxorder", "taxsuborder", "taxgrtgroup", "taxsubgrp"))
-  rownames(taxsub) <- NULL
+  taxsub <- as.data.frame(data.table::rbindlist(lapply(decompose_taxon_code(res$code), function(x) {
+    y <- taxon_code_to_taxon(as.character(rev(x)))
+    z <- data.frame(taxsubgrp = NA_character_, taxgrtgroup = NA_character_,
+                    taxsuborder = NA_character_, taxorder = NA_character_,
+                    stringsAsFactors = FALSE)
+    z[1, ] <- tail(c(rep(NA_character_, 4), y), 4)
+    z
+  })), stringsAsFactors = FALSE)
 
   res4 <- lapply(seq_along(res2), function(i) {
       x <- res2[[i]]
@@ -160,9 +167,9 @@ parse_family <- function(family, column_metadata = TRUE, flat = TRUE) {
 
   res5 <- as.list(data.table::rbindlist(c(list(basetbl), res4), fill = TRUE))
   multi.names <- c("taxminalogy", "taxfamother")
-  .FUN <- function(x) list(x)
-  .flat_FUN <- function(x) {
-    y <- paste0(na.omit(x), collapse = ", ")
+  .FUN <- function(x, sep = NULL) list(x)
+  .flat_FUN <- function(x, sep = ", ") {
+    y <- paste0(na.omit(x), collapse = sep)
     if (nchar(y) == 0) return(NA_character_)
     y
   }
@@ -171,7 +178,8 @@ parse_family <- function(family, column_metadata = TRUE, flat = TRUE) {
   }
 
   res5[multi.names] <- lapply(multi.names, function(n) {
-      res6 <- apply(data.frame(res5[names(res5) %in% n]), 1, .FUN)
+      res6 <- apply(data.frame(res5[names(res5) %in% n]), 1, .FUN,
+                    sep = ifelse(n == "taxminalogy", " over ", ", "))
       res6 <- lapply(res6, function(nn) {
         nnn <- nn[[1]]
         lr6 <- length(nnn)

data-raw/package-datasets.R

@@ -74,7 +74,11 @@ ST_higher_taxa_codes_13th <- jsonlite::fromJSON("https://raw.githubusercontent.c
 colnames(ST_higher_taxa_codes_13th) <- c("code", "taxon")
 usethis::use_data(ST_higher_taxa_codes_13th, overwrite = TRUE)
 
-latest_taxa <- ST_higher_taxa_codes_13th
+ST_higher_taxa_codes_12th <- jsonlite::fromJSON("https://raw.githubusercontent.com/ncss-tech/SoilKnowledgeBase/main/inst/extdata/KST/2014_KST_codes.json")
+colnames(ST_higher_taxa_codes_12th) <- c("code", "taxon")
+usethis::use_data(ST_higher_taxa_codes_12th, overwrite = TRUE)
+
+latest_taxa <- ST_higher_taxa_codes_12th
 
 # re-arrange taxa according to letter codes in the 'Keys
 .uniqueTaxaLogicalOrdering <- function(x) {
@@ -104,18 +108,17 @@ usethis::use_data(ST_unique_list, overwrite = TRUE)
 ## formative element dictionaries
 load('misc/formative-elements/formative-elements.rda')
 ST_formative_elements <- ST.formative_elements
-names(ST_formative_elements) <- c("order","suborder","greatgroup","subgroup")
+names(ST_formative_elements) <- c("order", "suborder", "greatgroup", "subgroup")
 
 # find formative elements in order names and add to table
 y <- ST_formative_elements[["order"]]
 res <- data.frame(y$order, stringr::str_locate(y$order, gsub("(.*)s$","\\1", y$element)))
-colnames(res) <- c("order","element_start","element_end")
+colnames(res) <- c("order", "element_start", "element_end")
 ST_formative_elements[["order"]] <- merge(ST_formative_elements[["order"]], res, by = "order")
 
 usethis::use_data(ST_formative_elements, overwrite = TRUE)
 
-ST_feature_SKB <- jsonlite::read_json("https://github.com/ncss-tech/SoilKnowledgeBase/raw/main/inst/extdata/KST/2014_KST_EN_featurelist.json",
-                                      simplifyVector = TRUE)
+ST_feature_SKB <- jsonlite::read_json("https://github.com/ncss-tech/SoilKnowledgeBase/raw/main/inst/extdata/KST/2014_KST_EN_featurelist.json", simplifyVector = TRUE)
 
 # handle marked UTF8 strings
 ST_feature_SKB$description <- sapply(ST_feature_SKB$description, stringi::stri_enc_toascii)