When I call the user defined function sRGB_to_CAM16UCS
in the console, it displays the result as intended. But when I try to call it within a while loop it throws an error. Can somebody help me understand the error?
library(purrr)
library(tibble)
library(tidyr)
sRGB_to_CAM16UCS <- function(R255, G255, B255){
# Convert sRGB to 1931 CIE XYZ [IEC 61966-2–1:2003(E)]
## Convert to the range of 0 to 1
R1 <- R255 / 255
G1 <- G255 / 255
B1 <- B255 / 255
## Gamma Expansion of sRGB values
gamma_inverse <- function(RGB1){
if (RGB1 < -0.04045 | RGB1 > 0.04045){
((RGB1 + 0.055)/1.055)^2.4
} else {
RGB1/12.92
}
}
R_li <- gamma_inverse(R1)
G_li <- gamma_inverse(G1)
B_li <- gamma_inverse(B1)
# Convert linear RGB values to CIE XYZ
X <- 41.24 * R_li + 35.76 * G_li + 18.05 * B_li
Y <- 21.26 * R_li + 71.52 * G_li + 07.22 * B_li
Z <- 01.93 * R_li + 11.92 * G_li + 95.05 * B_li
# Convert XYZ to CAM16
## User defined Parameters
X_w <- 96.4212
Y_w <- 100
Z_w <- 82.5188
L_A <- 40
Y_b <- 20
surround <- 2
discounting <- FALSE
## Predefined functions and constants
### M16
M16 <- matrix(c(0.401288,-0.250268,-0.002079,
0.650173, 1.204414, 0.048952,
-0.051461, 0.045854, 0.953127), nrow = 3, ncol=3)
### lerp
lerp <- function(a,b,c){
(1 - c) * a + c * b
}
### Crop
crop <- function(a,b,c){
pmin(pmax(c, a), b)
}
### Define adapt
adapt <- function(component){
con <- (F_L * abs(component) * 0.01)^0.42
sign(component) * 400 * con / (con + 27.13)
}
### Define unadapt
unadapt <- function(component){
sign(component) * 100 / F_L * ((27.13* abs(component))/(400-abs(component)))^2.38095238095
}
# Calculations
## Calculate "c"
if (surround >=1){
c <- lerp(0.59, 0.69, surround-1)
}else{
c <- lerp(0.525, 0.59, surround)
}
## Calculate "F" and "N_c"
if (c >= 0.59){
N_c <- lerp(0.9, 1.0, (c - 0.59)/.1)
} else {
N_c <- lerp(0.8, 0.9, (c - 0.525)/0.065)
}
## Calculate "k"
k <- 1/(5*L_A + 1)
## Calculate F_L
F_L <- k^4 * L_A + 0.1 * (1-k^4)^2 * (5 * L_A)^0.33333333333
## Calculate n
n <- Y_b / Y_w
## Calculate z
z <- 1.48 + sqrt(n)
## Calculate N_bb
N_bb <- 0.725 * n^-0.2
## Calculate D
if (discounting == FALSE){
D <- crop(0,1,N_c* (1 - 1/3.6 * exp((-L_A - 42)/92)))
}else {
D <- 1
}
## Calculate the "RGB_w"
RGB_w <- matrix(c(M16[1,1] * X_w + M16[1,2] * Y_w + M16[1,3] * Z_w,
M16[2,1] * X_w + M16[2,2] * Y_w + M16[2,3] * Z_w,
M16[3,1] * X_w + M16[3,2] * Y_w + M16[3,3] * Z_w), nrow = 3, ncol=1)
# Calculate the "D_RGB"
D_RGB <- apply(RGB_w, c(1, 2), function(x)((1 - D) * 1 + D * Y_w/x))
# Calculate the "D_RGB_inv"
D_RGB_inv <- apply(D_RGB,c(1, 2),function(x)1/x)
# Calculate the "RGB_cw"
RGB_cw <- RGB_w*D_RGB
# Calculate RGB_aw
RGB_aw <- apply(RGB_cw, c(1,2), adapt)
# Calculate A_w
A_w <- N_bb * ( 2 * RGB_aw[1,1] + RGB_aw[2,1] + 0.05 * RGB_aw[3,1])
# Calculate RGB_a
R_a <- adapt((M16[1,1] * X + M16[1,2] * Y + M16[1,3] * Z) * D_RGB[1,1])
B_a <- adapt((M16[2,1] * X + M16[2,2] * Y + M16[2,3] * Z) * D_RGB[2,1])
G_a <- adapt((M16[3,1] * X + M16[3,2] * Y + M16[3,3] * Z) * D_RGB[3,1])
# Calculate Hue
a <- R_a + (-12 * G_a + B_a) / 11
b <- (R_a + G_a - 2 * B_a) / 9
h_rad <- atan2(b, a)
h_ucs <- h_rad*(180.0/pi)
# Calculate Lightness (J)
e_t <- 0.25 * (cos(h_rad + 2) + 3.8)
A <- N_bb * (2*R_a + G_a + 0.05*B_a)
J <- 100 * ((A / A_w)^(c*z))
J_ucs <- 1.7 * J / (1 + 0.007 * J)
# Calculate brightness (Q)
Q <- 4/c * sqrt(J/100) * (A_w + 4) * (F_L^0.25)
# Calculate chroma (C)
t <- (5000 / 13 * N_c * N_bb * e_t * sqrt(a*a + b*b)) / (R_a + G_a + 1.05 * B_a + 0.305)
alpha <- t^0.9*(1.64 - 0.29^n)^0.73
C <- alpha * sqrt(J/100)
# Calculate colorfulness (M)
M <- C * F_L^0.25
M_ucs <- log(1 + 0.0228 * M) / 0.0228
# Calculate redness-greenness(a)
a_ucs <- M * cos(h_rad)
# Calculate yellowness-blueness(b)
b_ucs <- M * sin(h_rad)
# Calculate Saturation (s)
s <- 50 * sqrt(alpha*c /(A_w + 4))
return(tibble(R255, G255, B255, h_ucs, J_ucs ,M_ucs ,a_ucs, b_ucs))
}
nc <- 5
rgb_vals <- tibble(r1 = rdunif(nc, b=255, a=0), g1 = rdunif(nc, b=255, a=0), b1 = rdunif(nc, b=255, a=0))
test <- 1
test_df <- tibble(h_ucs = numeric(), J_ucs = numeric(), M_ucs = numeric(), a_ucs = numeric(), b_ucs = numeric())
while(test <= nrow(rgb_vals)){
test_r <- sRGB_to_CAM16UCS(rgb_vals[test, 1],rgb_vals[test, 2],rgb_vals[test, 3])
test_df <- rbind(test_df, test_r)
test <- test + 1
}
output <- cbind(rgb_vals, test_df)
print(output)
openxlsx::write.xlsx(output, "rgb2camucs.xlsx")
threw an error as following
Error in atan2(b, a) : non-numeric argument to mathematical function
>
> output <- cbind(rgb_vals, test_df)
Error in data.frame(..., check.names = FALSE) :
arguments imply differing number of rows: 5, 0
> print(output)
Error in print(output) : object 'output' not found
UPDATE: If I wrap the a and b with as.numeric()
function, it throws the following error message:
Error:
! Column names `r1`, `r1`, `r1`, `r1`, `r1`, and 1 more must not be duplicated.
Use .name_repair to specify repair.
Caused by error in `repaired_names()`:
! Names must be unique.
x These names are duplicated:
* "r1" at locations 1, 2, 3, 5, 6, etc.
Run `rlang::last_error()` to see where the error occurred.
>
This is because b
and a
are indeed non-numeric arguments. They are data.frames
.
Replacing that line with h_rad <- atan2(b$r1, a$r1)
makes it work as class(b$r1)
results in numeric
. Note that the last line of code where output
is exported to an XLSX does not work.
You can also "unpack" your 1x1 data.frame
using double brackets before calling your method, i.e., say test_r <- sRGB_to_CAM16UCS(rgb_vals[[test, 1]],rgb_vals[[test, 2]],rgb_vals[[test, 3]])
instead of test_r <- sRGB_to_CAM16UCS(rgb_vals[test, 1],rgb_vals[test, 2],rgb_vals[test, 3])
near the end of your code. This way you are passing the plain numbers to your function. This way, also the export to XLSX works.
I found this using RStudio's debugger, setting a breakpoint to that line and then entering class(b)
into the console on the bottom.