Major changes to the download_ssurgo()

_code/download_ssurgo.R

@@ -0,0 +1,213 @@
+
+source("_code/SaxtonRawls.R")
+
+
+Int <- function (X,Y,method) {
+  if(all(is.na(X))){rep(NA, length(X))}
+  else { approx(X, Y, rule=2,  xout=1:length(X)-1,method=method)$y}
+}
+
+
+download_SSURGO <- function(SiteName = "field2",
+                            north=NULL,south=NULL,east=NULL,west=NULL,
+                            map=TRUE,
+                            soilLayer_breaks = c(1,5,10,20,30,50,80,120,160,200),
+                            interpolation_Method = c("linear", "constant")) {
+
+
+  #SiteName = "field1";north=42.010759;south=42.01000;east=-93.740682;west=-93.741712;map=T
+
+  # Load packages
+  require(sp)
+  require(FedData)
+  require(raster)
+  require(dplyr)
+
+  a <- polygon_from_extent(extent(east, west, north, south),
+                           proj4string="+proj=longlat")
+
+  x <- get_ssurgo(template=a, label=SiteName)
+
+
+  # Extract useful data #############################
+
+  component <- x$tabular$component
+  chorizon <- x$tabular$chorizon
+  mapunit <-x$tabular$mapunit
+  majcomp <- component[component$majcompflag == "Yes", c("compname",
+                                                         "taxclname",
+                                                         "drainagecl",
+                                                         "mukey","cokey","slope.r","hydgrp")]
+  ### Plot make a map
+
+  if(map) { 
+    plot(x$spatial)
+    invisible(text(getSpPPolygonsLabptSlots(x$spatial), labels=as.character((majcomp$compname)), cex=1))
+  }
+
+  # Merge data ########################################
+
+  majcomp<- merge(data.frame(mukey=as.character(x$spatial$MUKEY),
+                             musym=as.character(x$spatial$MUSYM)),
+                  majcomp)
+
+
+  # Calculate % of area
+  area <- data.frame(musym=x$spatial$MUSYM, area=NA)
+  for (i in 1:length(x$spatial$MUSYM)) area$area[i] <- x$spatial@polygons[[i]]@area
+  area$area <- area$area/sum(area$area)
+
+  # Merge into dataset
+  majcomp <- merge(majcomp, area)
+  majcomp <- merge(majcomp,chorizon)
+
+  # Create horizons
+  h <- majcomp[order(majcomp$compname, majcomp$hzdept.r),]
+  h <- h[,c("compname","area","slope.r", "hydgrp",
+            "hzdept.r","hzdepb.r","hzthk.r",
+            "sandtotal.r","claytotal.r",
+            "dbthirdbar.r","dbovendry.r", 
+            "om.r","ksat.r",
+            "wfifteenbar.r","wthirdbar.r","ph1to1h2o.r")]
+
+  names(h) <- c("name","area","slope","hydrogroup","top","bottom","thick","sand","clay","wetbd","drybd", "om","ksat","ll","dul","ph")
+
+  # Bin slope groups
+  hydrogroup <- readRDS("_data/hydrogroup.rds")
+  h$slope_code <- .bincode(h$slope, breaks=c(0,2,5,10,100))
+  h <- left_join(h,hydrogroup) # merge dataset
+
+  # Expand soil layers
+  h$center <- trunc(h$top + h$thick/2)
+
+  h<- merge(merge(data.frame(name=rep(unique(h$name),
+                                  each=max(soilLayer_breaks)+1),
+                         center=0:max(soilLayer_breaks)),
+              unique(h[,c("name","area","slope","hydrogroup","top","bottom","thick","slope_code","CN2")])),
+        h, all=T)
+
+  h <- h[h$center >= h$top & h$center < h$bottom,] 
+
+  soils <- vector("list", length(unique(h$name)))
+
+  for(i in 1:length(unique(h$name))){
+      soil <- h[h$name == unique(h$name)[i], -1]
+
+      for(j in 10:length(names(soil))){
+        soil[,j] <- Int(X=soil$center, Y=soil[,j] , method = interpolation_Method[1]) 
+      }
+
+      # Calculate new variables ###########################
+
+      #soil$bd <- SaxtonRawls(pSand=soil$sand ,pClay=soil$clay, pOM=soil$om)$BD
+      soil$bd <- ifelse( soil$wetbd < 0.9, 0.9, ifelse(soil$wetbd > 1.8, 1.8,soil$wetbd))
+
+      #soil$ll.sr <- SaxtonRawls(pSand=soil$sand ,pClay=soil$clay, pOM=soil$om)$LL15
+      #soil$dul.sr <- SaxtonRawls(pSand=soil$sand ,pClay=soil$clay, pOM=soil$om)$DUL
+
+      soil$ksat <- soil$ksat*1000/1.157 # mm/day
+
+      soil$sat <- SaxtonRawls(pSand=soil$sand ,pClay=soil$clay, pOM=soil$om)$SAT/100
+
+      soil$ph <- 0.52+1.06*soil$ph #pH 1:5
+
+      soil$oc <- soil$om/1.72 # %
+
+      soil$U <- ifelse(soil$clay<=20,5+0.175*soil$clay,
+                    ifelse(soil$clay<=40,7.5+0.05*soil$clay,
+                           ifelse(soil$clay<=50,11.5-0.05*soil$clay,
+                                  ifelse(soil$clay<=70,12.75-0.075*soil$clay,
+                                         ifelse(soil$clay<=80,11-0.05*soil$clay,0))))) # mm
+
+      soil$conna <- ifelse(soil$clay<=30,0.025*soil$clay+3.25,
+                        ifelse(soil$clay<=50,4,
+                               ifelse(soil$clay<=70,-0.025*soil$clay+5.25,
+                                      ifelse(soil$clay<=80,3.5,0)))) # mm/d^5
+      soil$PO <- 1-soil$bd/2.65
+      soil$salb <- 0.13
+
+      soil$FINERT <- ifelse(soil$center<=1,0.4,
+                         ifelse(soil$center<=10,0.4,
+                                ifelse(soil$center<60,0.008*soil$center+0.32,
+                                       ifelse(soil$center<=120,0.8,
+                                              ifelse(soil$center<180,0.0032*soil$center+0.42,
+                                                     ifelse(soil$center<=300,0.99,0)))))) #(0-1)
+
+      soil$FBIOM <- ifelse(soil$center<=10,0.04,
+                        ifelse(soil$center<=20,0.055-0.0015*soil$center,
+                               ifelse(soil$center<=30,0.03-0.0005*soil$center,
+                                      ifelse(soil$center<60,0.0216-0.0002*soil$center,
+                                             ifelse(soil$center<=300,0.01,0))))) #(0-1)
+
+      soil$MWCON <- 1 #(0-1)
+
+      soil$CNsoil <- 13
+
+      soil$rootWt <- 1000
+
+      soil$DiffusConst <- 40
+
+      soil$DiffusSlope <- 16
+
+      soil$CnRed <- 20 #residue runoff
+
+      soil$CnCov	 <- 0.8
+
+      soil$EnrAcoeff	<- 7.4
+
+      soil$EnrBcoeff	<- 0.2
+
+      soil$XF_maize <- 1
+
+      soil$KL_maize <-	ifelse(soil$center<=20,0.08,0.09*exp(-0.007*soil$center))
+
+      soil$e	<- 0.5  #ifelse(F4=$BC$3,0.07,IF(F4=$BC$4,0.03,0.05))
+
+      soil$dul <- soil$dul/100
+
+      soil$ll <- soil$ll/100
+
+      soil$SWCON <- (soil$PO-soil$dul)/soil$PO
+
+      soil$AirDry <- ifelse(soil$center<=15,0.5,ifelse(soil$center<=30,0.9,1))*soil$ll
+
+      # Bin by layer
+
+      soil$layer <- .bincode(soil$center, breaks=c(-1,soilLayer_breaks[soilLayer_breaks>0]))
+
+      soil %>%
+        group_by(layer) %>%
+        summarise(top=min(center),
+                  bottom=max(center),
+                  area=mean(area),
+                  sand=mean(sand),
+                  clay=mean(clay),
+                  bd=mean(bd),
+                  ll=mean(ll),
+                  dul=mean(dul),
+                  ksat=mean(ksat),
+                  sat=mean(sat),
+                  oc=mean(oc),
+                  ph=mean(ph),
+                  FBIOM=mean(FBIOM),
+                  FINERT=mean(FINERT),
+                  U = mean(U)
+                  conna = mean(conna)
+                  ) -> soil
+
+
+      # Save df into list ###########
+
+
+      soils[[i]] <- data.frame(soil)
+
+  }
+
+  names(soils) <- (unique(h$name))
+
+  return(soils)
+}
+
+### Example 
+#soils <-  download_SSURGO(SiteName = "field2",north=42.010759,south=42.01000,east=-93.740682,west=-93.741712)
+#View(soils[2])

_code/hydrogroup.R

@@ -0,0 +1,25 @@
+# Runoff hydological groups table
+
+require(tidyr)
+hydrogroup <- data.frame(matrix(data=c(61,64,68,71,73,76,80,83,81,84,88,91,84,87,91,94),
+                            ncol = 4,nrow = 4,
+                            dimnames = list(c(1,2,3,4),
+                                            LETTERS[1:4])))
+
+
+hydrogroup$"A/B" <- 0.5*(hydrogroup[,1]+hydrogroup[,1+1])
+hydrogroup$"A/C" <- 0.5*(hydrogroup[,1]+hydrogroup[,1+2])
+hydrogroup$"A/D" <- 0.5*(hydrogroup[,1]+hydrogroup[,1+3])
+
+hydrogroup$"B/C" <- 0.5*(hydrogroup[,2]+hydrogroup[,2+1])
+hydrogroup$"B/D" <- 0.5*(hydrogroup[,2]+hydrogroup[,2+2])
+
+hydrogroup$"C/D" <- 0.5*(hydrogroup[,3]+hydrogroup[,3+1])
+
+
+hydrogroup$slope_code <- as.numeric(row.names(hydrogroup)) # slope groups "0-2","2-5","5-10","10-100"
+
+hydrogroup %>%
+  gather(key="hydrogroup",value="CN2", - slope_code) -> hydrogroup
+
+saveRDS(hydrogroup, "_data/hydrogroup.rds")