library(aqp)
library(soilDB)
# get lab / morphologic data
x <- fetchKSSL(series = 'clarksville', returnMorphologicData = TRUE, simplifyColors = TRUE)
# extract SoilProfileCollection
s <- x$SPC
# remove horizons that are missing moist colors
s <- subsetHz(s, !is.na(m_hue) & !is.na(m_value) & !is.na(m_chroma))
# remove profiles with missing horizons due to above steps
s <- HzDepthLogicSubset(s)
# keep only profiles with > 2 horizons
idx <- which(profileApply(s, nrow) > 2)
s <- s[idx, ]
# re-assemble Munsell color notation for moist color
s$color <- sprintf("%s %s/%s", s$m_hue, s$m_value, s$m_chroma)
One approach: extract the first n profiles having > 5 horizons, and first 6 horizons.
# filter to just those profiles with > 5 horizons
idx <- which(profileApply(s, nrow) > 5)
# take the first n profiles, all horizons
n <- 6
w <- s[idx[1:n], 1:6]
# check
par(mar=c(0,0,0,0))
plotSPC(w, color = 'moist_soil_color', cex.names = 0.75, width = 0.35, name.style = 'center-center', plot.depth.axis = FALSE, hz.depths = TRUE, fixLabelCollisions = TRUE, hz.depths.offset = 0.06)
Less restrictive: first n profiles, all horizons.
n <- 6
w <- s[1:n, ]
# check
par(mar=c(0,0,0,0))
plotSPC(w, color = 'moist_soil_color', cex.names = 0.75, width = 0.35, name.style = 'center-center', plot.depth.axis = FALSE, hz.depths = TRUE, hz.depths.offset = 0.06)
Regularize horizons / colors to k rows.
regularizeColors <- function(i, k = 6) {
.col <- colorRampPalette(na.omit(i$moist_soil_color), space = 'Lab', interpolate = 'spline')(k)
.munsell <- col2Munsell(t(col2rgb(.col)))
.munsell <- sprintf("%s %s/%s", .munsell$hue, .munsell$value, .munsell$chroma)
return(list(col = .col, munsell = .munsell))
}
mm <- profileApply(w, simplify = FALSE, FUN = regularizeColors, k = 6)
Make a k row by n column grid of soil colors from above.
m <- lapply(mm, '[[', 'col')
m <- do.call('cbind', m)
# m <- matrix(m$moist_soil_color, nrow = 6, ncol = 5, byrow = FALSE)
par(mar=c(0,0,0,0))
plot(1, 1, type='n', axes=FALSE, xlab='', ylab='', ylim=c(6.5, 0.5), xlim=c(0.5, n+0.5), asp = 1)
# vectorized functions are the best
rect(xleft = col(m) - 0.4, ybottom = row(m) + 0.4, xright = col(m) + 0.4, ytop = row(m) - 0.4, col = m, border = NA)
Annotate with Munsell colors.
.munsell <- lapply(mm, '[[', 'munsell')
.munsell <- do.call('c', .munsell)
par(mar=c(0,0,0,0))
plot(1, 1, type='n', axes=FALSE, xlab='', ylab='', ylim=c(6.5, 0.5), xlim=c(0.5, n+0.5), asp = 1)
# vectorized functions are the best
rect(xleft = col(m) - 0.4, ybottom = row(m) + 0.4, xright = col(m) + 0.4, ytop = row(m) - 0.4, col = m, border = NA)
text(x = col(m), y = row(m), labels = .munsell, col = invertLabelColor(m), cex = 0.66, font = 2)
This time with rounded corners
library(berryFunctions)
par(mar=c(0,0,0,0))
plot(1, 1, type='n', axes=FALSE, xlab='', ylab='', ylim=c(6.5, 0.5), xlim=c(0.5, n+0.5), asp = 1)
# ugh
col.m <- col(m)
row.m <- row(m)
# not vectorized
for(i in seq_along(m)) {
roundedRect(xleft = col.m[i] - 0.4, ybottom = row.m[i] + 0.4, xright = col.m[i] + 0.4, ytop = row.m[i] - 0.4, col = m[[i]], border = NA, rounding = 0.25)
}
Arbitrary collection of profiles
library(sharpshootR)
data("OSDexamples")
s <- OSDexamples$SPC
s$color <- sprintf("%s %s/%s", s$hue, s$value, s$chroma)
s$moist_soil_color <- s$soil_color
mm <- profileApply(s, simplify = FALSE, FUN = regularizeColors, k = 8)
m <- lapply(mm, '[[', 'col')
m <- do.call('cbind', m)
n <- length(s)
# init plot region
par(mar=c(0,0,0,0))
plot(1, 1, type='n', axes=FALSE, xlab='', ylab='', ylim=c(6.5, 0.5), xlim=c(0.5, n+0.5), asp = 1)
# keep track of column and row indices for simpler plotting
col.m <- col(m)
row.m <- row(m)
# roundedRect() not vectorized
for(i in seq_along(m)) {
roundedRect(
xleft = col.m[i] - 0.4,
ybottom = row.m[i] + 0.4,
xright = col.m[i] + 0.4,
ytop = row.m[i] - 0.4,
col = m[[i]],
border = NA,
rounding = 0.25
)
}