R/patch.R

In facelab/webmorph: Reproducible Stimuli

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