#' Patch colour
#'
#' Get the median (or mean or user-defined function) colour value of a specified patch of pixels on an image. This is useful for matching background colours.
#'
#' @param img The image
#' @param x1 starting x pixel of patch
#' @param x2 ending x pixel of patch
#' @param y1 starting y pixel of patch
#' @param y2 ending y pixel of patch
#' @param color The type of color to return (hex, rgb)
#' @param func The function to apply to an array of rgba values to determine the central colour (defaults to median)
#'
#' @return hex or rgba color value
#' @export
#'
#' @examples
#' patch(demo_stim()[[1]]$img)
#'
patch <- function(img, x1 = 1, x2 = 10, y1 = 1, y2 = 10,
color = c("hex", "rgb"), func = stats::median) {
if (!"magick-image" %in% class(img)) {
stop("img must be 'magick-image'")
}
color <- match.arg(color)
pixels <- magick::image_raster(img) %>%
dplyr::filter(.data$x >= x1,
.data$x <= x2,
.data$y >= y1,
.data$y <= y2)
central_col <- grDevices::col2rgb(pixels$col, alpha = TRUE) %>%
apply(1, func)
if (color == "rgb") {
return(central_col)
}
# return hex value
grDevices::rgb(
central_col[['red']],
central_col[['green']],
central_col[['blue']],
central_col[['alpha']],
maxColorValue = 255
)
}
#' Get pixel values
#'
#' @param stimuli list of class stimlist
#' @param color type of color values to return
#'
#' @return data frame of pixel x and y values, plus colour values for each image
#' @export
#'
#' @examples
#'
#' # this can take a long time with big images
#' demo_stim("test") %>%
#' resize(5/338) %>% # resize to 5x5 pixels for demo
#' pixels()
#'
pixels <- function(stimuli, color = c("hex", "rgb", "hsv", "lab")) {
stimuli <- validate_stimlist(stimuli)
color <- match.arg(color)
pixels <- lapply(stimuli, `[[`, "img") %>%
lapply(magick::image_raster) %>%
# convert colours
lapply(function(df) {
if (color == "rgb") {
rgb <- grDevices::col2rgb(df$col, alpha = TRUE)
if (all(rgb[1, ] == rgb[2, ]) && all(rgb[1, ] == rgb[3, ])) {
df$gs <- rgb["red", ] # greyscale
} else {
df$r <- rgb["red", ]
df$g <- rgb["green", ]
df$b <- rgb["blue", ]
}
if (all(unique(rgb["alpha", ]) != 255)) {
df$alpha <- rgb["alpha", ]
}
df$col <- NULL
} else if (color == "hsv") {
rgb <- grDevices::col2rgb(df$col, TRUE)
hsv <- grDevices::rgb2hsv(rgb[1:3, ])
df$h <- hsv["h", ]
df$s <- hsv["s", ]
df$v <- hsv["v", ]
if (all(unique(rgb["alpha", ]) != 255)) {
df$alpha <- rgb["alpha", ]
}
df$col <- NULL
} else if (color == "lab") {
lab <- col2lab(df$col)
df$l <- lab$L
df$a <- lab$a
df$b <- lab$b
df$col <- NULL
} else if (color == "hex") {
names(df)[3] <- "hex"
}
tidyr::gather(df, "color", "value", 3:ncol(df))
}) %>%
purrr::reduce(dplyr::left_join, by = c("x", "y", "color"))
names(pixels) <- c("x", "y", "color", names(stimuli))
pixels
}
#' Color to Lab Conversion
#'
#' R color to LAB colourspace conversion.
#'
#' @param col vector of hex or color names
#'
#' @return list of L, a and b values
#' @export
#'
#' @examples
#' col2lab(c("red", "green", "blue"))
#'
col2lab <- function(col) {
# checked at http://www.brucelindbloom.com/index.html?ColorCheckerCalcHelp.html
# RGB to XYZ via http://www.easyrgb.com/index.php?X=MATH&H=02#text2
#change to 0-1
rgb <- grDevices::col2rgb(col)/255
# inverse sRGB companding
rgb2 <- apply(rgb, 1, function(v) {
100 * ifelse( v > 0.04045,
`^`( (( v + 0.055 ) / 1.055 ), 2.4),
v / 12.92
)
}) %>% matrix(nrow = ncol(rgb)) # for 1-pixel images
# Observer. = 2°, Illuminant = D65
X = rgb2[, 1] * 0.4124 + rgb2[, 2] * 0.3576 + rgb2[, 3] * 0.1805
Y = rgb2[, 1] * 0.2126 + rgb2[, 2] * 0.7152 + rgb2[, 3] * 0.0722
Z = rgb2[, 1] * 0.0193 + rgb2[, 2] * 0.1192 + rgb2[, 3] * 0.9505
# XYZ to CieL*ab via http://www.easyrgb.com/index.php?X=MATH&H=07#text7
# Observer= 2°, Illuminant= D65
#see http://www.brucelindbloom.com/index.html?ColorCheckerCalcHelp.html for other values
ref_X = 95.047
ref_Y = 100.000
ref_Z = 108.883
xyz <- list(
'x' = X / ref_X,
'y' = Y / ref_Y,
'z' = Z / ref_Z
) %>% lapply(function(v) {
ifelse( v > 0.008856,
`^`(v, 1/3 ),
(7.787 * v) + (16 / 116))
})
list(
L = ( 116 * xyz$y ) - 16,
a = 500 * ( xyz$x - xyz$y ),
b = 200 * ( xyz$y - xyz$z )
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.