half-value chip interpolation works well, but leads to many non-stand…

…ard chips in the `munsell` reference set #318

This breaks many existing tests, and many years of expected behavior.

R/munsell2rgb.R

@@ -382,11 +382,16 @@ munsell2rgb <- function(the_hue, the_value, the_chroma, alpha = 1, maxColorValue
   # plyr::join() 2x faster than base::merge
   # data.table::merge() (with conversion to/from) 5x faster than base::merge()
 
+
   ## TODO: maybe more efficient with keys
   # round-trip through data.table is still faster
   d <- data.table::as.data.table(d)
   munsell <- data.table::as.data.table(munsell)
 
+
+  ## TODO: optimize by first filtering full lookup table on e.g. hue
+
+
   # join
   res <- merge(d, munsell, by = c('hue','value','chroma'), all.x = TRUE, sort = FALSE)
 

misc/utils/Munsell/interpolate-spectra.R

@@ -1,6 +1,6 @@
 library(lattice)
 library(tactile)
-library(pbapply)
+library(purrr)
 library(reshape2)
 
 # load simplified spectra
@@ -47,7 +47,7 @@ interpolateOddChromaSpectra <- function(i) {
   # short circuit: 0 candidates for interpolation
   if(length(s.chroma) < 1)
     return(NULL)
-    
+
 
   # setup interpolation function: natural splines
   # fit is exact at training points
@@ -89,7 +89,7 @@ interpolateOddChromaSpectra <- function(i) {
 }
 
 # do interpolation
-mm <- pblapply(m, interpolateOddChromaSpectra)
+mm <- map(m, .f = interpolateOddChromaSpectra, .progress = TRUE)
 
 # combine
 mm <- do.call('rbind', mm)
@@ -109,6 +109,16 @@ xyplot(reflectance ~ chroma | factor(wavelength), data=s,
        par.settings = tactile.theme()
 )
 
+idx <- which(m.final$hue %in% c('2.5YR') & m.final$value == 4)
+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
 m.final[m.final$reflectance <= 0, ]
@@ -133,7 +143,7 @@ m.final$reflectance[idx] <- min(m.final$reflectance[-idx])
 
 
 ## check: OK
-s <- subset(m.final, subset = hue == '2.5YR' & value == 4 & chroma %in% 2:4)
+s <- subset(m.final, subset = hue == '5YR' & value == 4 & chroma %in% 2:4)
 
 xyplot(reflectance ~ wavelength, data = s, 
        groups = munsell, type='b',
@@ -143,6 +153,15 @@ xyplot(reflectance ~ wavelength, data = s,
 )
 
 
+s <- subset(m.final, subset = hue == '2.5Y' & value == 4 & 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 2.5 value
@@ -195,7 +214,7 @@ interpolateValueSpectra <- function(i) {
 
 
 # do interpolation
-mm <- pblapply(m, interpolateValueSpectra)
+mm <- map(m, .f = interpolateValueSpectra, .progress = TRUE)
 
 # combine
 mm <- do.call('rbind', mm)
@@ -238,6 +257,11 @@ save(munsell.spectra, file = '../../../data/munsell.spectra.rda', compress = 'xz
 save(munsell.spectra.wide, file = '../../../data/munsell.spectra.wide.rda', compress = 'xz')
 
 # cleanup
-unlink(c('interpolated-Munsell-spectra-wide.rds', 'interpolated-Munsell-spectra.rds', 'simplified-Munsell-spectra.rds'))
+unlink(
+  c('interpolated-Munsell-spectra-wide.rds', 
+    'interpolated-Munsell-spectra.rds', 
+    'simplified-Munsell-spectra.rds'
+  )
+)
 
 

misc/utils/Munsell/local-functions.R

@@ -38,8 +38,47 @@ interpolateChroma <- function(m.i) {
 }
 
 
-## TODO: consider re-writing for entire range, and splinefun() based interpolation
+# 2024-09-26
+# re-write of interpolateValue() -> now safely interpolates all 0.5 values
+interpolateValue2 <- function(m.i) {
+
+  # can only proceed with >=2 rows
+  # some combinations of hue, value, chroma have 1 row.
+  # there will be other combinations created by split() with 0 rows
+  if(nrow(m.i) < 2) {
+    return(NULL)
+  }
+
+  # linear interpolation ~ munsell value
+  # x ~ V
+  s.1 <- splinefun(m.i$V, m.i$x)
+  # y ~ V
+  s.2 <- splinefun(m.i$V, m.i$y)
+  # Y ~ V
+  s.3 <- splinefun(m.i$V, m.i$Y)
+
+  # all odd values
+  new.V <- seq(from = min(m.i$V) + 0.5, to = max(m.i$V) - 0.5, by = 1)
+
+  # combine interpolated values into data.frame
+  # H, C are constant
+  m.new <- data.frame(
+    H = m.i$H[1],
+    V = new.V,
+    C = m.i$C[1],
+    p1 = s.1(new.V),
+    p2 = s.2(new.V),
+    p3 = s.3(new.V)
+  )
+
+  names(m.new) <- c('H', 'V', 'C', 'x', 'y', 'Y')
+
+  # only return new rows
+  return(m.new)
+}
+
 
+## NOTE: this can only interpolate between two integer values
 # 2022-03-29
 # for now only interpolating 2.5 value
 # usually interpolating xyY, 

misc/utils/Munsell/main.R

@@ -1,9 +1,11 @@
 ## Code / Data related to preparation of Munsell color interpretation in aqp
-## 2022-03-29
+## 2024-09-26
 ## D.E. Beaudette, A.G. Brown
 
 # make Munsell and related LUT
-# add neutral chips
+# + neutral chips
+# + odd chroma
+# + 0.5 value 
 # xyY [C] -> XYZ [D65] -> sRGB -> CIELAB
 source('prepare-munsell-LUT.R')