R/swatches.R

In hypercompetent/xstitch: Cross-stitch pattern generation.

#' Extract swatch RGB values from a raw RGB array
#'
#' @param arr The 3D RGB array to use
#' @param xmin The position of the leftmost pixel column
#' @param xmax The position of the rightmost pixel column
#' @param ymin The position of the topmost pixel row
#' @param ymax The position of the bottom pixel row
#'
#' @return a 3-column matrix with numeric values for red, green, and blue between 0 and 255
#' @export
#'
extract_swatch <- function(arr, xmin, xmax, ymin, ymax) {
  n <- length(xmin:xmax) * length(ymin:ymax)
  res <- matrix(0, ncol = 3, nrow = n)
  res[,1] <- as.numeric(arr[1, xmin:xmax, ymin:ymax])
  res[,2] <- as.numeric(arr[2, xmin:xmax, ymin:ymax])
  res[,3] <- as.numeric(arr[3, xmin:xmax, ymin:ymax])
  colnames(res) <- c("r","g","b")
  res
}

#' Compute the most frequent hex value from an RGB matrix
#'
#' @param swatch_mat A 3-column swatch matrix like that generated by extract_swatch()
#'
#' @return A single hex color value
#' @export
#'
swatch_most_frequent_hex <- function(swatch_mat) {
  u <- unique(swatch_mat)
  uc <- apply(u, 1, function(x) {
    sum(apply(swatch_mat, 1, function(y) {
      identical(y,x)
    }))
  })
  mfu <- u[which(uc == max(uc)),]

  if(!is.null(dim(mfu))) {
    mfu <- mfu[1,]
  }

  rgb(mfu["r"],
      mfu["g"],
      mfu["b"],
      maxColorValue = 255)
}

#' Compute the median hex value from an RGB matrix
#'
#' The median is based on the median of the sums of the separate RGB values.
#'
#' @param swatch_mat A 3-column swatch matrix like that generated by extract_swatch()
#'
#' @return A single hex color value
#' @export
#'
swatch_median_hex <- function(swatch_mat) {
  sums <- rowSums(swatch_mat)
  sums_med <- median(sums)
  if(!sums_med %in% sums) {
    med_diffs <- abs(sums_med - sums)
    sums_med <- sums[which(med_diffs == min(med_diffs))]
  }

  med_mat <- swatch_mat[which(sums %in% sums_med),,drop = FALSE]

  r <- floor(median(med_mat[,"r"]))
  g <- floor(median(med_mat[,"g"]))
  b <- floor(median(med_mat[,"b"]))

  rgb(r, g, b, maxColorValue = 255)
}

#' Compute the minimum hex value from an RGB matrix
#'
#' The minimum is based on the minimum of the sums of the separate RGB values.
#'
#' @param swatch_mat A 3-column swatch matrix like that generated by extract_swatch()
#'
#' @return A single hex color value
#' @export
#'
swatch_min_hex <- function(swatch_mat) {
  sums <- rowSums(swatch_mat)
  sums_min <- min(sums)

  min_mat <- swatch_mat[which(sums == sums_min),,drop = FALSE]

  r <- floor(median(min_mat[,"r"]))
  g <- floor(median(min_mat[,"g"]))
  b <- floor(median(min_mat[,"b"]))

  rgb(r, g, b, maxColorValue = 255)
}

#' Compute the maximum hex value from an RGB matrix
#'
#' The maximum is based on the maximum of the sums of the separate RGB values.
#'
#' @param swatch_mat A 3-column swatch matrix like that generated by extract_swatch()
#'
#' @return A single hex color value
#' @export
#'
swatch_max_hex <- function(swatch_mat) {
  sums <- rowSums(swatch_mat)
  sums_max <- max(sums)

  max_mat <- swatch_mat[which(sums == sums_max),,drop = FALSE]

  r <- floor(median(max_mat[,"r"]))
  g <- floor(median(max_mat[,"g"]))
  b <- floor(median(max_mat[,"b"]))

  rgb(r, g, b, maxColorValue = 255)
}

#' Filter an RGB matrix to remove values with low V in HSV space
#'
#' This removes darker/dimmer colors
#'
#' @param swatch_mat A 3-column swatch matrix like that generated by extract_swatch()
#' @param prop The minimum V value to retain
#'
#' @return A 3-column swatch matrix
#' @export
#'
swatch_filter_value <- function(swatch_mat,
                                prop = 0.3) {
  swatch_hsv <- rgb2hsv(t(swatch_mat))
  cutoff <- quantile(swatch_hsv["v",], probs = prop)
  keep <- swatch_hsv["v",] >= cutoff
  swatch_mat[keep,]
}

#' Compute the closest R color for a set of hex colors
#'
#' This uses colors(distinct = TRUE).
#'
#' @param hexes A character vector of the hex color codes
#'
#' @return A character vector of color names.
#' @export
#'
nearest_r_color <- function(hexes) {
  r_rgb <- col2rgb(colors(distinct = TRUE))
  colnames(r_rgb) <- colors(distinct = TRUE)

  map_chr(hexes,
          function(hex) {
            diffs <- apply(r_rgb, 2, function(x) {
              sum(abs(x - col2rgb(hex)))
            })
            colnames(r_rgb)[which(diffs == min(diffs))][1]
          })

}

#' Convert colors to alpha-beta values
#'
#' See https://en.wikipedia.org/wiki/HSL_and_HSV#Hue_and_chroma for more information.
#'
#' @param hexes A character vector with a set of hex color values or R colors
#'
#' @return a data.frame with columns for the original color, alpha, and beta values.
#'
col2ab <- function(hexes) {
  rgbs <- col2rgb(hexes) / 255
  alphas <- rgbs["red",] - 0.5 * (rgbs["green",] + rgbs["blue",])
  betas <- sqrt(3) / 2 * (rgbs["green",] - rgbs["blue",])
  return(data.frame(color = hexes,
                    alpha = alphas,
                    beta = betas))
}

#' Generate a plot in alpha-beta colorspace for a palette
#'
#' The resulting plot will be a 2-D projection onto the HSV/HSL chromaticity plane.
#' See https://en.wikipedia.org/wiki/HSL_and_HSV#Hue_and_chroma for more information.
#'
#' @param palette a character vector containing colors as either hex values (starting with #) or R colors
#' @param show_pures a logical value indicating whether or not to plot points for pure colors
#'
#' @return a ggplot2 plot with palette colors in alpha-beta space.
#'
colorspace_plot <- function(palette,
                            show_pures = TRUE) {

  data <- col2ab(palette)

  p <- ggplot(data) +
    geom_point(aes(x = alpha,
                   y = beta,
                   color = color),
               size = 2) +
    scale_color_identity() +
    theme_classic() +
    scale_x_continuous(limits = c(-1.1,1.1)) +
    scale_y_continuous(limits = c(-1.1,1.1))

  if(show_pures) {
    pure_colors <- c("#FF0000","#FFFF00","#00FF00","#00FFFF","#0000FF","#FF00FF")
    pure_df <- col2ab(pure_colors)
    p <- p + geom_point(data = pure_df,
                        aes(x = alpha,
                            y = beta,
                            fill = color),
                        size = 4,
                        pch = 21) +
      scale_fill_identity()
  }

  return(p)
}