Clarksville.

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)

A E1 E2 2Eb 2Bt1 2Bt2 0 15 51 78 92 124 170 20121 A E1 E2 E3 B1 B/Bm 0 3 10 28 46 66 94 2548 A E Bt1 Bt2 Bt3 2Bt4 0 8 25 41 64 99 132 40889 A Bt1 Bt2 2Bt3 2Bt4 2Bt5 0 15 28 36 46 64 76 40947 A Bt1 Bt2 Bt3 Bt4 2Btx1 0 13 23 38 46 61 79 40948 A E Bt1 Bt2 2Bt3 2Bt3 0 18 36 51 66 81 97 40950

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)

A E1 E2 2Eb 2Bt1 2Bt2 0 15 51 78 92 124 170 20121 Ae Bw1 Bt1 Bt2 0 5 18 25 43 22576 A E1 E2 E3 B1 B/Bm 0 3 10 28 46 66 94 2548 A E Bt1 Bt2 Bt3 2Bt4 2Bt5 2Bt6 0 8 25 41 64 99 132 165 190 40889 A Bt1 Bt2 2Bt3 2Bt4 2Bt5 2Bt6 2Bt6 2Bt7 3Bt8 3Bt8 0 15 28 36 46 64 76 89 99 112 130 147 40947 A Bt1 Bt2 Bt3 Bt4 2Btx1 2Btx1 2Btx2 2Btx2 0 13 23 38 46 61 79 99 117 135 40948

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)

10YR 3/2 10YR 6/3 10YR 6/2 10YR 6/4 5YR 5/6 5YR 5/6 10YR 4/2 10YR 5/4 10YR 5/4 10YR 5/4 10YR 5/4 10YR 6/4 10YR 4/1 10YR 4/2 10YR 5/3 10YR 5/3 10YR 5/4 10YR 7/4 10YR 3/2 10YR 6/4 5YR 5/6 5YR 4/6 2.5YR 4/6 5YR 4/6 10YR 4/3 10YR 5/6 7.5YR 5/6 7.5YR 5/6 7.5YR 4/6 7.5YR 5/4 10YR 3/2 10YR 5/4 10YR 4/4 7.5YR 4/6 7.5YR 4/6 7.5YR 4/6

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
  )
}

US State Soils

library(sharpshootR)
data("us.state.soils")

s <- fetchOSD(us.state.soils$series)

# splice-in state names
s$series <- site(s)$id
us.state.soils$series <- toupper(us.state.soils$series)
site(s) <- us.state.soils

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)
# hide this plot
d <- SoilTaxonomyDendrogram(s, KST.order = TRUE)
# re-order based on subgroup classification
m <- m[, d$order]

# pdf(file = 'state-soils-chips.pdf', width = 18, height = 5)

# init plot region
par(mar=c(0,0,0,0.5))
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
  )
}

# annotate 
text(x = seq_along(s), y = 0.33, labels = site(s)$id[d$order], cex = 0.66, srt = 90, adj = 0, font = 2)

TANANA MYAKKA CHESUNCOOK MARLOW KALKASKA TUNBRIDGE TOKUL THREEBEAR HILO BAYAMON HOUSTON BLACK CASA GRANDE FORKWOOD PENISTAJA MIVIDA OROVADA JORY DICKSON MONONGAHELA TIFTON CECIL BAMA RUSTON DOWNER GREENWICH SASSAFRAS DRUMMER SCOBEY HARNEY HOLDREGE HOUDEK WILLIAMS PORT TAMA SEITZ SAN JOAQUIN CRIDER ANTIGO STUTTGART MIAMI MIAMIAN HONEOYE PAMUNKEY LESTER MENFRO VICTORY NATCHEZ PAXTON HAZLETON NARRAGANSETT BOHICKET WINDSOR 

# text(x = seq_along(s), y = 0.33, labels = s$subgroup[d$order], cex = 0.5, srt = 45, adj = 0, font = 2)
# text(x = seq_along(s), y = 0.33, labels = s$state[d$order], cex = 0.66, srt = 45, adj = 0, font = 2)

# dev.off()

This document is based on aqp version 2.2-1 and soilDB version 2.8.10.