R/to-format.R

In houyunhuang/tinycolor: Parse and Manipulate Colors with tinycolor.js

#' Convert color's format
#'
#' Convert a vector of colors to a given color format.
#'
#' @param x a any type color string or a javascript color object specifying.
#' @param type The formats will convert to.
#' @param  na.rm a logical value indicating whether NA values should be stripped before the computation proceeds.
#'
#' @return A string of the color in most cases.
#' @examples
#' to_hsv("red")
#' to_hsv_string("red")
#' to_hsl("#222")
#' to_hsl_string("#222")
#' to_hex("{r: 120, g: 90, b: 180}")
#' to_hex_string("{r: 120, g: 90, b: 180}")
#' to_hex8("{r: 120, g: 90, b: 180, a: 0.2}")
#' to_hex8_string("{r: 120, g: 90, b: 180, a: 0.2}")
#' to_rgb("blue")
#' to_rgb_string("blue")
#' to_percentrgb("#785AB4")
#' to_percentrgb_string("#785AB433")
#' to_name("#FF0000")
#' to_filter("red")
#' to_string("red")
#' @importFrom stats na.omit
convert_col <- function(x, type) {
  if(missing(type)) type <- "Hex8String"
  if(!missing(type))
    type <- match.arg(type, c("Hsv", "HsvString", "Hsl", "HslString", "Hex", "HexString",
                            "Hex8", "Hex8String", "Rgb", "RgbString", "PercentageRgb",
                            "PercentageRgbString", "Filter", "String"))
  if(!is.character(x)) x <- as.character(x)
  if(type %in% c("HsvString", "HslString", "Hex", "HexString",
                 "Hex8", "Hex8String", "RgbString","PercentageRgbString",
                 "Filter", "String")) {
    cmd <- ifelse(is_js_object(x),
                  paste0("tinycolor", "(", x, ")"),
                  paste0("tinycolor", "(\"", x, "\")"))
    cmd <- ifelse(is.na(cmd), NA, paste0(cmd, ".to", type, "()"))
    out <- v8_eval(cmd)
    return(out)
  }
  if(type %in% c("Hsv", "Hsl", "Rgb", "PercentageRgb")){
    out <- lapply(x, parse_obj, type = type)
    return(out)
  }

}

#' @rdname convert_col
#' @export
to_hsv <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Hsv")
  return(out)
}
#' @rdname convert_col
#' @export
to_hsv_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "HsvString")
  return(out)
}
#' @rdname convert_col
#' @export
to_hsl <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Hsl")
  return(out)
}
#' @rdname convert_col
#' @export
to_hsl_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "HslString")
  return(out)
}
#' @rdname convert_col
#' @export
to_hex <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Hex")
  return(out)
}
#' @rdname convert_col
#' @export
to_hex_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "HexString")
  return(out)
}
#' @rdname convert_col
#' @export
to_hex8 <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Hex8")
  return(out)
}
#' @rdname convert_col
#' @export
to_hex8_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Hex8String")
  return(out)
}
#' @rdname convert_col
#' @export
to_rgb <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Rgb")
  return(out)
}
#' @rdname convert_col
#' @export
to_rgb_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "RgbString")
  return(out)
}
#' @rdname convert_col
#' @export
to_percentrgb <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "PercentageRgb")
  return(out)
}
#' @rdname convert_col
#' @export
to_percentrgb_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "PercentageRgbString")
  return(out)
}
#' @rdname convert_col
#' @export
to_name <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  x <- to_hex(x)
  ct <- v8_tinycolor_context()
  cols <- ct$get("names")
  hex <- stringr::str_remove(as.character(cols), "#")
  nm <- setNames(names(cols), hex)
  out <- unname(nm[x])
  return(out)
}
#' @rdname convert_col
#' @export
to_filter <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "Filter")
  return(out)
}
#' @rdname convert_col
#' @export
to_string <- function(x, na.rm = FALSE) {
  if(na.rm) x <- x[!is.na(x)]
  out <- convert_col(x, type = "String")
  return(out)
}