smcolors: SM colour tools.

library(jpeg)
library(png)

#' Get image url quote list from Google.
#'
#' @param qword String. Image search key word.
#' @return An image url quote list with 20 entries.
#' Google limits number of images returned by 20.
#' @export
get.imglist <- function(qword) {
    qword <- sub(" ", "+", qword)
    qurl <- paste("https://www.google.com/search?q=",
		  qword, "&tbm=isch", sep = "")
    page <- readLines(qurl, warn = FALSE)
    imglist <- strsplit(page, "https://encr", fixed = TRUE)[[1]][-1]
    imglist <- paste("https://encr", imglist, sep = "")
    imglist <- sub("\\\".*width.*", "", imglist)
    return(imglist)
}


#' Import one image from an url quote, output 2d or 3d array.
#'
#' @param imgquote image url quote generated by \code{\link{get.imglist}}.
#' @param out2d If \code{TRUE}, the 3D array of the image will be
#' transformed into 2D.
#' @return A 2D or 3D array representing the image.
#' @export
import <- function(imgquote, out2d = FALSE) {
    handler <- tempfile()
    download.file(imgquote, handler, mode="wb", quiet = TRUE)
    if( is( try(readJPEG(handler), silent = TRUE), "try-error") )  {
	img <- readPNG(handler)  }
    else { img <- readJPEG(handler) }
    suppressWarnings(file.remove(handler))
    if (out2d) img <- apply(img, 3, rbind)
    return(img)
}


#' Print a raster image.
#'
#' @param img A raster image.
#' @return Draw raster image.
#' @export
draw <- function(img, ...) {
    w <- dim(img)[1]; h <- dim(img)[2]
    plot(c(0, 1), c(0, w/h), bty = "n", col = NA, axes = FALSE,
	 xlab = "", ylab = "", asp = 1, ...)
    rasterImage(img, 0, 0, 1, w/h)
}

#' Plot a colour bar.
#'
#' @param colornames A vector of colour names.
#' @param texts Whether to show text labels of colour names.
#' @return Draw a colour bar.
#' @export
draw.bar <- function(colornames, texts = TRUE) {
    n <- length(colornames)
    plot(n, 0, col = NA, pch = 16, cex = 2, bty = "n",
	 axes = FALSE, xlab = "", ylab = "",
	 ylim = c(0, 0.5), xlim = c(0, n), asp = 1)
    for (i in 1:n) {
	rect(i-1,0,i,0.5, col = colornames[i], border = NA)

	if (texts) {
	    text(i-1/2, -0.1, cex = max(5/n, 0.4), colornames[i])
	    text(i-1/2, 0.7,  cex = max(5/n, 0.4), i)
	}
    }
}

#' View 20 Google image search results.
#'
#' @param qword String. Image search key word.
#' @details Google limits number of images returned by 20.
#' @seealso \code{\link{hunt.colors}}
#' @export
#' @examples
#' show.imgs("stardew valley")
#' hunt.colors("stardew valley", 10, 1:10)
show.imgs <- function(qword) {
    imglist <- get.imglist(qword)
    par(mfrow = c(5, 4), mar = c(0,0,0.6,0))
    for(i in 1:20) draw(import(imglist[i]), main = i)
}


#' Find main colours by k-means.
#'
#' @param img A 2D or 3D array. 3D arrays will be transformed into 2D.
#' @param num Number of colours to extract.
#' @param seed Seed for k-means.
#' @export
k.colors <- function(img, num = 5, seed = 42) {
    if (length(dim(img)) == 3) allpixels <- apply(img, 3, rbind)
    else if (length(dim(img)) == 2) allpixels <- img
    else stop("Image dimension error. Try harder.")
    set.seed(seed)
    allpixels.km <- kmeans(allpixels, num)
    out <- apply(allpixels.km$centers, 1, function(r)
		 rgb(r[1], r[2], r[3]))
    out <- out[order(out)]
    return(out)
}




fill.seq <- function(sq) {
    pos <- matrix(NA, nrow = 2, ncol = length(which(!is.na(sq))))
    pos[1, ] <- which(!is.na(sq))
    pos[2, ] <- c(pos[1, -1], length(sq))
    for (i in 1:dim(pos)[2]) {
	sq[pos[1, i] : pos[2, i]] <-
	    seq(sq[pos[1, i]], sq[pos[2, i]], length = pos[2,i]-pos[1,i]+1)
    }
    return(sq)
}



#' Extract colours from Google image search results.
#'
#' @param qword String. Image search key word.
#' @param num Number of colours to extract.
#' @param index An integer or a vector indicating which image(s) to use.
#' Images can be viewed using \code{show.imgs}.
#' @param seed Seed for k-means.
#' @param plot Whether to plot the colours.
#' @return A vector of colour names.
#' @seealso \code{\link{show.imgs}}.
#' @export
#' @examples
#' show.imgs("stardew valley")
#' hunt.colors("stardew valley", 10, 1:10)
hunt.colors <- function(qword, num = 5, index = 1, seed = 42,
			plot = TRUE) {
    imglist <- get.imglist(qword)
    allimgs <- import(imglist[index[1]], out2d = TRUE)
    if (length(index) > 1) {
	for (i in index[-1]) {
	    img <- import(imglist[i], out2d = TRUE)
	    allimgs <- rbind(allimgs, img)
	}
    }
    km <- k.colors(allimgs, num, seed)
    names(km) <- NULL
    if (plot) draw.bar(km)
    return(km)
}


make.gradient2 <- function(from = NULL, to = NULL,
			  len = 5, fixed = NULL,
			  plot = TRUE) {
    if (!is.numeric(len) | as.integer(len) != len) {
	len <- 5
	warning("Length must be an integer. Defaulted to 5.")
    }
    if (len == 1) {
	if (plot) plot.bar(from)
	return(from)
    }
    if (!is.null(from) & !is.null(to) & !is.null(fixed)) {
	fixed <- NULL
	warning("Two-color gradient cannot be used in combination
		with fixed compents. No components fixed.")
    }
    method <- "rgb"
    mat <- matrix(NA, nrow = 3, ncol = len)
    lookup <- rep(c(1, 2, 3), 2)
    names(lookup) <- c("r", "g", "b", "h", "s", "v")
    if (!is.null (fixed)) {
	fixedones <- unlist(strsplit(fixed, ""))
	if (any(c("h", "s", "v") %in% fixedones) &
	    length(grep("[^hsv]", fixed)) == 0)
	    method <- "hsv"
	else if (any(c("r", "g", "b") %in% fixedones) &
		 length(grep("[^rgb]", fixed)) == 0 )
	    method <- "rgb"
	else {
	    fixed <- NULL
	    warning("Invalid fixed components. No components fixed.")
	    return(make.gradient(from, to, fixed = NULL, plot = plot,
				 len = len) )
	}
	locked.row <- lookup[fixedones]
	color <- col2rgb(from)
	if (method == "hsv") color <- rgb2hsv(color)
	else if (method == "rgb") color <- color / 255
	pos <- max(1, round (len * color[-locked.row][1]))
	mat[, pos] <- color
	mat[locked.row, ] <- mat[locked.row, pos]
	mat[-locked.row, 1] <- 0
	mat[-locked.row, len] <- 1

    }
    else {
	if (!is.null(to)) {
	    startvalue <- col2rgb(from) / 255
	    endvalue <- col2rgb(to) / 255
	    if (method == "hsv") {
		startvalue <- rgb2hsv(startvalue)
		endvalue <- rgb2hsv(endvalue)
	    }
	    mat[, 1] <- startvalue; mat[, len] <- endvalue
	}
	else {
	    if (!is.null(from)) {
		pos <- max(1, round(len * (mean(col2rgb(from) / 255))))
		left <- make.gradient2("black", from, plot = FALSE,
				      len = pos)
		right <- make.gradient2(from, "white", plot = FALSE,
				       len = (len - pos + 1))[-1]
		out <- c(left, right)
		if (plot) plot.bar(out)
		return(out)
	    }
	    else {
		return(make.gradient2("black", "white",
				     plot = plot, len = len))
	    }
	}
    }
    mat <- apply(mat, 1, fill.seq)
    if (method == "rgb") {
	out <- apply(t(mat), 2, function(c) rgb(c[1], c[2], c[3]))
    }
    else if (method == "hsv") {
	out <- apply(t(mat), 2, function(c) hsv(c[1], c[2], c[3]))
    }
    if (plot) draw.bar(out)
    return(out)
}

#' Make a colour gradient.
#'
#' @param ... Color names.
#' @param len Length of the gradient. If more than two colors, the length of
#' the step (A 4-colour gradient with \code{len = 5} gives 15 colours).
#' @param fixed A concatenated string indicating the fixed component(s) of
#' the gradient. One or two components (letters) of either \code{"rgb"} or
#' \code{"hsv"} can be specified. See details.
#' @param order If \code{TRUE}, colours are ordered to make a continuous
#' gradient from dark to light.
#' @param plot Whether to plot the gradient bar. Default \code{TRUE}.
#' @param texts Whether to add text labels to the bar. Default \code{TRUE}
#' @return A vector of colour names.
#' @details Examples of valid \code{fixed} are \code{"hv", "h", "rg"} etc.
#' Two-colour gradient cannot be used in combination with \code{fixed}.
#' If only one colour is specified, the colour's position in the gradient
#' is decided by its brightness (if \code{fixed} is \code{NULL}) or by its
#' value of the first fixed component (if \code{fixed} is specified).
#' @export
#' @examples
#' make.gradient()
#' make.gradient("turquoise", fixed = "hv")
#' make.gradient(cyans[1], blues[9], len = 8)
#' make.gradient(blues[1], reds[1], yellows[1], cyans[1])
make.gradient <- function(..., len = 5, fixed = NULL, order = FALSE,
			  plot = TRUE, texts = TRUE) {
    col.list <- c(...)
    if (order) {
	dist2black <- apply(sapply(col.list, col2rgb), 2,
			    function(c) dist(rbind(c, c(0,0,0))))
	col.list <- col.list[order(dist2black)]
    }

    if (length(col.list) == 1)
	out <- make.gradient2(..., len = len,
			      fixed = fixed, plot = FALSE)
    else if (length(col.list) == 2)
	out <- make.gradient2(col.list[1], col.list[2], len = len,
			      fixed = fixed, plot = FALSE)
    else {
	out <- NULL
	for (i in 2: length(col.list)) {
	    if (i < length(col.list)) {
	    out <- c(out,
		     make.gradient2(col.list[i-1], col.list[i],
				    len = len + 1, fixed = fixed,
				    plot = FALSE)[- (len+1)])
			      }
	else {
	    out <- c(out,
		      make.gradient2(col.list[i-1], col.list[i],
				    len = len, fixed = fixed,
				    plot = FALSE))
	}
	}
    }

    if(plot) draw.bar(out, texts)
    return(out)

}

#' Draw rectangles/ grids.
#'
#' @param xl First/ left-most xleft.
#' @param yt First/ top-most ytop.
#' @param w Width of rectangles.
#' @param h Height of rectangles.
#' @param ncol Number of columns.
#' @param nrow Number of rows. Default 1.
#' @param border Default to transparent.
#' @param add Default to \code{FALSE}.
#' @param col Fill colours of rects.
#' @param texts Text labels in the rectangles/ grid. Order is by column.
#' @param texts.col Can be colours or one of the two keywords \code{"auto"}
#' and \code{"theme"}. \code{"auto"} would make black/ white texts based on
#' the underlying rectangle colour. \code{"theme"} would choose the colours
#' from the colours supplied to rectangles. Darkest one would be the black
#' equivalent and lightest one the white equivalent. Works well on one-
#' colour gradients.
#' @param scale If \code{TRUE}, the fill colours of cells/ rectangles will
#' be based on the values in the cell (need to be numeric). \code{\link{
#' make.gradient}} can order the gradient key colours beforehand.
#' @return Draw rectangles.
#' @export
#' @examples
#' rects(0, 5, 1, 1, 5, 5, col = occblues, texts = 1:25)
rects <- function(xl, yt, w = 1, h = 1, ncol = 3, nrow = 1,
		  border = "transparent", add = FALSE, col = occblues,
		  texts = NULL, texts.col = "auto", scale = FALSE, ...) {

    if(length(xl) == 1 & length(yt) == 1) {
	xlefts <- seq(xl, by = w, len = ncol)
	xlefts <- rep(xlefts, each = nrow)
	ybottoms <- seq(yt - h, by = -h, len = nrow)
	ybottoms <- rep(ybottoms, ncol)
	xrights <- xlefts + w
	ytops <- ybottoms + h
    }

    if(length(xl) > 1 & length(yt) > 1) {
	xlefts <- xl
	ybottoms <- yt - h
	xrights <- xl + w
	ytops <- yt
    }

    if(add == FALSE) {
	plot(NULL, xlab = "", ylab = "", axes = FALSE, bty = "n",
	     xlim = c(min(xlefts), min(xlefts) + ncol * w),
	     ylim = c(max(ytops) - nrow * h, max(ytops)))
    }

    if (scale == TRUE) {
	texts <- as.numeric(texts)
	cuts <- cut(texts, length(col))
	col <- col[as.numeric(cuts)]

    }

    if(ncol * nrow < length(col) & scale == FALSE) col <- col[1:(ncol*nrow)]



    dist2white <- apply(sapply(col, col2rgb), 2,
			function(c) dist(rbind(c, c(255,255,255))))
    dist2black <- apply(sapply(col, col2rgb), 2,
			function(c) dist(rbind(c, c(0,0,0))))

    if(texts.col == "auto") {
	texts.col <- ifelse(dist2black < dist2white, "white", "black")
    }

    else if (texts.col == "theme") {
	coldark <- col[which.min(dist2black)]
	collight <- col[which.min(dist2white)]
	texts.col <- ifelse(dist2black < dist2white, collight, coldark)

    }

    return({
	rect(xlefts, ybottoms, xrights, ytops,
	     border = border, col = col, ...)
	if (!is.null(texts)) {
	    text(xlefts + w/2, ybottoms + h/2, lab = texts,
		 col = texts.col)
	}
				    })

}


#' Pick n most distinctive colours out of many colours.
#'
#' @param colornames A vetor of colour names.
#' @param n How many colours to pick.
#' @param plot Whether to plot the colour bar. Default \code{FALSE}.
#' @return Picked colour names (ordered from dark to light).
#' @details Makes the process of choosing colours easier especially when
#' choosing legend colours in a list of gradient theme colours.
#' @export
#' @examples
#' pink.n(make.gradient(occblues, len = 2), len = 8, plot = TRUE)
pick.n <- function(colornames, n, plot = FALSE) {

    nofx <- function(n, x) {
	x <- x[order(x)]
	combo <- combn(x[-c(1, length(x))], n - 2)
	combo <- rbind(x[1], combo, x[length(x)])
	combo[, which.max(apply( combo, 2, function(c) min(diff(c)) ))]
    }

    dist2black <- apply(sapply(colornames, col2rgb), 2,
			function(c) dist(rbind(c, c(0,0,0))))
    if (n == 1) out <- colornames[sample(1:length(colornames), 1)]
    else if (n == 2) out <- colornames[c(which.min(dist2black),
					 which.max(dist2black))]
    else {
	out <- colornames[which(dist2black %in% nofx(n, dist2black)) ]
	out <- out[!is.na(out)]
    }

    out <- out[order(dist2black[out])]

    if(plot) draw.bar(out)
    out
}



smart.gradient <- function(..., len = 5) {

    col.list <- list(...)

    col.list <- lapply(col.list, function(l) l[sample(length(l), 3)])
    grid <- as.data.frame(expand.grid(col.list))
    if (nrow(grid) > 15) grid <- grid[sample(nrow(grid), 15), ]
    par(mfrow = c(5, 3), mar = rep(0, 4))
    apply(grid, 1, make.gradient, len = len)


}

#' Set up a null plot.
#'
#' @param xl0,xl1 xlim. Default c(0, 5).
#' @param yl0,yl1 ylim. Default c(0, 5).
#' @export
setup.null <- function(xl0 = 0, xl1 = 5, yl0 = 0 , yl1 = 5) {
    plot(NULL, xlab = "", ylab = "", axes = FALSE,
	 xlim = c(xl0, xl1), ylim - c(yl0, yl1))
}


#' @export
pinks <- c("pink", "lightpink", "hotpink", "deeppink",
	   "palevioletred", "mediumvioletred")

#' @export
reds <- c("lightsalmon", "salmon", "darksalmon", "lightcoral",
	  "indianred", "firebrick", "darkred", "red")

#' @export
oranges <- c("orangered", "tomato", "coral", "darkorange",
	     "orange")

#' @export
yellows <- c("yellow", "lightyellow", "lemonchiffon",
	     "lightgoldenrodyellow", "papayawhip", "moccasin",
	     "peachpuff", "palegoldenrod", "khaki", "darkkhaki",
	     "gold")

#' @export
browns <- c("cornsilk", "blanchedalmond", "bisque", "navajowhite",
	    "wheat", "burlywood", "tan", "rosybrown", "sandybrown",
	    "goldenrod", "darkgoldenrod", "peru", "chocolate",
	    "saddlebrown", "sienna", "brown", "maroon")

#' @export
greens <- c("darkolivegreen", "olivedrab", "yellowgreen",
	    "limegreen", "lawngreen", "chartreuse",
	    "greenyellow", "springgreen", "mediumspringgreen",
	    "lightgreen", "palegreen", "darkseagreen", "mediumaquamarine",
	    "mediumseagreen", "seagreen", "forestgreen", "green",
	    "darkgreen")

#' @export
cyans <- c("cyan", "lightcyan", "paleturquoise", "aquamarine",
	   "turquoise", "mediumturquoise", "lightseagreen", "cadetblue",
	   "darkcyan")

#' @export
blues <- c("lightsteelblue", "powderblue", "lightblue", "skyblue",
	   "lightskyblue", "deepskyblue", "dodgerblue", "cornflowerblue",
	   "steelblue", "royalblue", "blue", "mediumblue", "darkblue",
	   "navy", "midnightblue")

#' @export
purples <- c("lavender", "thistle", "plum", "violet", "orchid",
	     "magenta", "mediumorchid", "mediumpurple",
	     "blueviolet", "darkviolet", "darkorchid", "darkmagenta",
	     "purple", "darkslateblue", "mediumslateblue")

#' @export
whites <- c("white", "snow", "honeydew", "mintcream", "azure",
	    "aliceblue", "ghostwhite", "whitesmoke", "seashell",
	    "beige", "oldlace", "floralwhite", "ivory", "antiquewhite",
	    "linen", "lavenderblush", "mistyrose")

#' @export
grays <- c("gainsboro", "lightgray", "darkgray", "gray",
	   "dimgray", "lightslategray", "slategray", "darkslategray",
	   "black")


#' @export
html.colors <- list(pinks=pinks, reds=reds, oranges=oranges,
		    yellows=yellows, browns=browns, greens=greens,
		    cyans=cyans, blues=blues, purples=purples,
		    whites=whites, grays=grays)

#' @export
occblues <- c("#CCDDEC", "#99BAD9", "#669DC5",
	      "#3375B2", "#00539F", "#002C54")

#' @export
occgrays <- c("#C0C0C0", "#969696", "#808080")

#' @export
occgreens  <- c("#D1E3D1", "#AFCDAB", "#7FB27F",
		"#579A57", "#2B802B", "#006600")

#' @export
occtaupes <- c("#E6DCD7", "#D7C8BE", "#BEAA96", "#968C78", "#827864")

#' @export
occteals <- c("#99D5D5", "#6CC0C0", "#48A6A6", "#3F8E8C", "#33726D" )

#' @export
occ.colors <- list(occblues = occblues,
		   occgrays = occgrays,
		   occgreens  = occgreens,
		   occteals = occteals,
		   occtaupes = occtaupes)

#' @export
xlred <- rgb(248, 105, 107, max = 255)

#' @export
xlyellow <- rgb(255, 235,132, max = 255)

#' @export
xlgreen <- rgb(99, 190, 123, max = 255)

#' @export
xl.colors <- list(xlred = xlred, xlyellow = xlyellow, xlgreen = xlgreen)

#' @export
preset.colors <- list(html.colors = html.colors,
		      xl.colors = xl.colors,
		      occ.colors = occ.colors)