R/utils.R

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

#' Insert NAs into a vector based on another one.
#'
#' @param x vector without NAs.
#' @param from vector from which the NAs must be inserted in x.
#' @noRd
#' @examples
#' x <- c(1, NA, 2)
#' y <- na.omit(x)
#' na_insert(y^2, from=x)
na_insert <- function(x, from) {
  if (length(x) == length(from)) {
    x[is.na(from)] <- NA
  } else if ((length(from) - sum(is.na(from))) == length(x)) {
    x <- replace(from, !is.na(from), x)
  } else {
    stop("Incompatible number of missing values")
  }
  return(x)
}


#' Functions to check if an vector is a javascript objects.
#'
#' @param x a color string vector.
#' @noRd
#' @examples
#' x <- "{ h: 0.5, s: 0.5, l: 0.5 }"
#' is_js_object(x)
#' y <- c("{ r: 1, g: 0, b: 0 }", "{ h: .5, s: .5, v: .5 }")
#' is_js_object(y)
is_js_object <- function(x) {
  if(!is.character(x))
    x <- as.character(x)
  mod_ratio <- "\\s*\\{\\s*[rh]\\s*:\\s*[01](\\.\\d*)?\\s*,\\s*[gs]\\s*:\\s*[01](\\.\\d*)?\\s*,\\s*[blv]\\s*:\\s*[01](\\.\\d*)?\\s*(,\\s*a\\s*:\\s*[01](\\.\\d*)?\\s*)?\\}"
  mod <- "\\s*\\{\\s*[rh]\\s*:\\s*\\d+\\s*,\\s*[gs]\\s*:\\s*\\d+\\s*,\\s*[blv]\\s*:\\s*\\d+\\s*(,\\s*a\\s*:\\s*[01](\\.\\d*)?\\s*)?\\}"
  out <- grepl(mod_ratio, x, ignore.case = TRUE) | grepl(mod, x, ignore.case = TRUE)
  out <- na_insert(out, x)
  return(out)
}

#' Color Combinations converts.
#'
#' @param cmd Color combinations command.
#' @param to The format converts to.
#' @noRd
parse_color <- function(cmd, to = "HexString") {
  if(!is.character(cmd))
    cmd <- as.character(cmd)
  cmd <- paste0(cmd, ".map(function(t) { return t.to", to, "(); })")
  out <- v8_eval(cmd)
  return(out)
}

#' Handle the js object return.
#'
#' @param x color string vector.
#' @param type The format converts to.
#' @noRd
parse_obj <- function(x, type = c("Hsv", "Hsl", "Rgb", "PercentageRgb")) {
  if(length(x) != 1) stop("`x` must be vector with length 1", call. = FALSE)
  if(is.na(x)) return(NA)
  type <- match.arg(type)
  cmd <- ifelse(is_js_object(x),
                paste0("var col = tinycolor", "(", x, ").to", type, "()"),
                paste0("var col = tinycolor", "(\"", x, "\").to", type, "()"))
  ct <- v8_tinycolor_context()
  ct$eval(cmd)
  col <- unlist(ct$get("col"))
  return(col)
}