bug fix in spectral library preparation and subsequent interpolation of spectra

Author: dylanbeaudette

data/munsell.spectra.rda

@@ -3,6 +3,7 @@
 ##
 
 
+## TODO: test extrapolation of "1-chroma" spectra
 
 ## TODO: clamp to original range of Munsell chroma and value
 ## TODO: coordinate with `prepare-munsell-LUT.R`
@@ -36,6 +37,19 @@ xyplot(reflectance ~ chroma | factor(wavelength), data=s,
        par.settings = tactile.theme()
 )
 
+idx <- which(m.rel$hue %in% c('7.5YR') & m.rel$value == 4)
+s <- m.rel[idx, ]
+
+xyplot(reflectance ~ chroma | factor(wavelength), data=s, 
+       type='b', as.table=TRUE,
+       scales = list(y = list(tick.number = 10)),
+       auto.key=list(lines=TRUE, points=FALSE, cex=1, space='right'),
+       par.settings = tactile.theme()
+)
+
+
+
+
 # split by hue/value/wavelength
 m <- split(m.rel, list(m.rel$hue, m.rel$value, m.rel$wavelength))
 
@@ -69,6 +83,16 @@ xyplot(reflectance ~ chroma | factor(wavelength), data=s,
        par.settings = tactile.theme()
 )
 
+# 8.5 values
+idx <- which(m.final$hue %in% c('7.5Y') & m.final$value == 8.5)
+s <- m.final[idx, ]
+
+xyplot(reflectance ~ chroma | factor(wavelength), data=s, 
+       type='b', as.table=TRUE,
+       scales = list(y = list(tick.number = 10)),
+       par.settings = tactile.theme()
+)
+
 
 
 # check for reflectance <= 0
@@ -125,8 +149,20 @@ xyplot(reflectance ~ wavelength, data = s,
 )
 
 
+# 2025-06-03: fixed long-standing bug in REGEX-parsing of reflectance database
+s <- subset(m.final, subset = hue == '2.5Y' & value == 8.5 & chroma %in% 2:4)
+
+xyplot(reflectance ~ wavelength, data = s, 
+       groups = munsell, type='b',
+       scales = list(y = list(tick.number = 10)),
+       auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 3),
+       par.settings = tactile.theme()
+)
+
+
 
 ## interpolate spectra for select half-chip Munsell values
+# note: there are some 8.5 value spectra in the source data (hues: "10Y"  "2.5Y" "5Y"   "7.5Y")
 
 # split by hue/chroma/wavelength
 m <- split(m.final, list(m.final$hue, m.final$chroma, m.final$wavelength))
@@ -148,7 +184,7 @@ str(m.final)
 
 
 # check for reflectance <= 0
-# 3403 rows, all very close to 0
+# 3368 rows, all very close to 0
 # most of these are very low value + low chroma | low value + high chroma
 nrow(m.final[m.final$reflectance <= 0, ])
 
@@ -181,12 +217,13 @@ xyplot(reflectance ~ wavelength, data = s,
        par.settings = tactile.theme()
 )
 
+# there should be no duplication of the few "8.5 value" spectra
 s <- subset(m.final, subset = hue == '2.5Y' & chroma == 4 & value %in% c(7, 8, 8.5, 9, 9.5, 10))
 
 xyplot(reflectance ~ wavelength, data = s, 
        groups = munsell, type='b',
        scales = list(y = list(tick.number = 10)),
-       auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 3),
+       auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 5),
        par.settings = tactile.theme()
 )
 

misc/utils/Munsell/interpolate-spectra.R

@@ -1,4 +1,5 @@
 library(purrr)
+devtools::load_all()
 
 data("munsell.spectra.wide")
 

misc/utils/Munsell/investigate-spectral-interpolation-errors.R

@@ -69,17 +69,22 @@ interpolateOddChromaSpectra <- function(i) {
 
 interpolateValueSpectra <- function(i) {
 
+  # new Munsell values
+  v.target <- c(2.5, 8.5, 9.5)
+  
   # 0 or 1 row input: no interpolation possible
-  if(nrow(i) < 2)
+  if(nrow(i) < 2) {
     return(NULL)
+  }
+  
+  # there are a few spectra associated with 8.5 values
+  # if present, ignore 
+  v.target <- setdiff(v.target, i$value)
 
   # setup interpolation function: natural splines
   # fit is exact at training points
   a.fun <- splinefun(i$value, i$reflectance, method = 'natural')
 
-  # new Munsell values
-  v.target <- c(2.5, 8.5, 9.5)
-  
   # re-assemble into original format
   res <- data.frame(
     munsell = sprintf("%s %s/%s", i$hue[1], v.target, i$chroma[1]),

misc/utils/Munsell/local-functions.R

@@ -1,5 +1,5 @@
 ## Code / Data related to preparation of Munsell color interpretation in aqp
-## 2024-10-03
+## 2025-06-03
 ## D.E. Beaudette, A.G. Brown
 
 # make Munsell and related LUT

misc/utils/Munsell/main.R

@@ -2,6 +2,19 @@
 ##
 ##
 
+## From the internal description:
+# This file contains spectral reflectance measurements of X-Rite's 2007 Munsell Book
+# of Color (Glossy Finish).  The measurements were made in 2012 with a ColorMunki
+# spectrophotometer.  The first column is the Munsell name.  The remaining 
+# columns give reflectance values for 380 nm to 730 nm, in steps
+# of 10 nm.  The reflectance is a value between 0 (indicating that no light at that
+# wavelength is reflected) and 1 (indicating that all the light at that wavelength
+# is reflected).  Occasionally an entry is slightly greater than 1.  The likely cause
+# is random variability, and those entries can be adjusted to 1 with negligible loss.
+# In all, 1485 colour samples were measured.  Researchers are invited to analyze
+# the data in this file.
+
+library(aqp)
 library(reshape2)
 
 # missing odd chroma
@@ -18,22 +31,40 @@ m$v <- as.numeric(gsub(pattern = 'X', replacement = '', x = m$variable))
 m <- m[, c('Name', 'v', 'value')]
 names(m) <- c('munsell', 'wavelength', 'reflectance')
 
-# this is clever
-# split into Munsell pieces
+# reflectance values > 1 should be clamped at 1
+# see description above
+m$reflectance <- pmin(m$reflectance, 1)
+
+# 
+# 2025-06-03: more precise Munsell parsing REGEX
+# verified with https://regexr.com/
+#
+# the main problem here is that the munsell notation in the refelctance library
+# is specified without a space, and there are some 8.5 values in there
+# --> 10YR4/5, 5Y8.5/2, 2.5BG6/6, etc.
+# 
 d <- strcapture(
-  '([[[:digit:][:alpha:].]+)([[:digit:]]+)/([[:digit:]]+)', 
+  '([[:digit:]]+[.]?[[:digit:]]?[[:alpha:]]+)([[:digit:].]+)/([[:digit:]]+)', 
   m$munsell, 
-  proto = data.frame(hue=character(), value=integer(), chroma=integer(), stringsAsFactors = FALSE)
+  proto = data.frame(
+    hue = character(), 
+    value = numeric(), 
+    chroma = integer(), 
+    stringsAsFactors = FALSE
+  )
 )
 
-# check: some funky ones in there:
-# 10Y8.
-# 7.5Y8.
-table(d$hue)
+# check: OK
+sort(tab <- table(d$hue))
+
+# all hues accounted for
+.hp <- huePosition(returnHues = TRUE, includeNeutral = FALSE)
+setdiff(names(tab), .hp)
+setdiff(.hp, names(tab))
 
-# OK
-table(d$value)
-table(d$chroma)
+# all standard values and 
+table(d$value, useNA = 'always')
+table(d$chroma, useNA = 'always')
 
 
 # re-assemble