Nothing
#' GUI: Color Picker
#'
#' A graphical user interface (\acronym{GUI}) for selecting a color.
#'
#' @param col character.
#' Initial color, see \sQuote{Value} section
#' @param parent tkwin.
#' \acronym{GUI} parent window
#'
#' @return Returns a selected color in terms of its \code{RGB} components,
#' a string of the form \code{"#RRGGBB"} where each of the pairs
#' \code{RR}, \code{GG}, \code{BB} consist of two hexadecimal digits
#' giving a value in the range \code{00} to \code{FF}.
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @seealso \code{\link[grDevices]{col2rgb}}
#'
#' @keywords misc
#'
#' @import tcltk
#'
#' @export
#'
#' @examples
#' \dontrun{
#' ChooseColor(col = "#669933")
#' }
#'
ChooseColor <- function(col, parent=NULL) {
# save color and quit
SaveColor <- function() {
col.hex <- Txt2hex(tclvalue(col.var))
if (col.hex == "")
col.hex <- NA
rtn.col <<- col.hex
tclvalue(tt.done.var) <- 1
}
# draw polygon on color sample
DrawSamplePolygon <- function(fill) {
tcl(f0.cvs.1, "delete", "col")
pts <- .Tcl.args(c(0, 0, dx, 0, dx, dy, 0, dy))
tkcreate(f0.cvs.1, "polygon", pts, fill=fill, outline="", tag="col")
}
# draw polygon on color chart
DrawChartPolygon <- function(i, j, fill, outline, tag) {
x1 <- j * dx - dx
y1 <- i * dy - dy
x2 <- j * dx
y2 <- i * dy
pts <- .Tcl.args(c(x1, y1, x2, y1, x2, y2, x1, y2) - 0.5)
tkcreate(f1.cvs, "polygon", pts, fill=fill, outline=outline, tag=tag)
}
# build color chart
BuildColorChart <- function() {
for (i in seq_len(m)) {
for (j in seq_len(n)) {
DrawChartPolygon(i, j, fill=d[i, j], outline="black", tag="")
}
}
}
# update color ramp
UpdateColorRamp <- function(col.hex) {
cols <- c("#FFFFFF", col.hex, "#000000")
col.ramp <<- grDevices::colorRampPalette(cols, space="Lab")(n + 4)[3:(n + 2)]
tcl(f2.cvs, "delete", "ramp")
dx <- (w - 1) / n
x2 <- 1
y1 <- 1
y2 <- dy / 2
for (i in col.ramp) {
x1 <- x2
x2 <- x1 + dx
pts <- .Tcl.args(c(x1, y1, x2, y1, x2, y2, x1, y2))
tkcreate(f2.cvs, "polygon", pts, fill=i, tag="ramp")
}
}
# change color
ChangeColor <- function(col.hex, is.hsva=FALSE, is.color=FALSE) {
col.hex <- substr(col.hex, 1, 7)
if (is.na(col.hex) || col.hex == "")
col.hex <- "#000000"
tcl(f1.cvs, "delete", "browse")
if (col.hex %in% d) {
ij <- which(d == col.hex, arr.ind=TRUE)[1, ]
i <- ij[1]
j <- ij[2]
DrawChartPolygon(i, j, fill="", outline="white", tag="browse")
}
DrawSamplePolygon(col.hex)
UpdateColorRamp(col.hex)
if (!is.hsva) {
col.rgb <- grDevices::col2rgb(col.hex, alpha=FALSE)
col.hsv <- grDevices::rgb2hsv(col.rgb, maxColorValue=255)
nh <<- col.hsv[1]
ns <<- col.hsv[2]
nv <<- col.hsv[3]
tclvalue(h.scl.var) <- nh
tclvalue(s.scl.var) <- ns
tclvalue(v.scl.var) <- nv
tclvalue(a.scl.var) <- na
tclvalue(h.ent.var) <- sprintf("%.2f", nh)
tclvalue(s.ent.var) <- sprintf("%.2f", ns)
tclvalue(v.ent.var) <- sprintf("%.2f", nv)
tclvalue(a.ent.var) <- sprintf("%.2f", na)
}
if (!is.color) tclvalue(col.var) <- Hsv2hex()
}
# select ramp color
SelectRampColor <- function(x) {
i <- ceiling((as.numeric(x)) / ((w - 1) / n))
col.hex <- col.ramp[i]
ChangeColor(col.hex)
}
# select chart color
SelectChartColor <- function(x, y) {
tcl(f1.cvs, "delete", "browse")
i <- ceiling((as.numeric(y)) / dy)
j <- ceiling((as.numeric(x)) / dx)
if (i == 0) i <- 1
if (j == 0) j <- 1
DrawChartPolygon(i, j, fill="", outline="white", tag="browse")
ChangeColor(d[i, j])
}
# coerce text string to hexadecimal color
Txt2hex <- function(txt) {
txt <- CheckColorStr(as.character(txt))
if (substr(txt, 1, 1) != "#")
txt <- paste0("#", txt)
if (is.transparent)
fmt <- "%08s"
else
fmt <- "%06s"
fmt.txt <- gsub(" ", "0", sprintf(fmt, substr(txt, 2, nchar(txt))))
txt <- paste0("#", fmt.txt)
if (inherits(try(grDevices::col2rgb(txt), silent=TRUE), "try-error"))
txt <- ifelse(is.transparent, "#000000FF", "#000000")
return(txt)
}
# coerce numeric HSV values to hexadecimal color
Hsv2hex <- function() {
if (is.transparent)
col.hex <- grDevices::hsv(h=nh, s=ns, v=nv, alpha=na)
else
col.hex <- grDevices::hsv(h=nh, s=ns, v=nv)
return(col.hex)
}
# check range of numeric color attribute
CheckColorNum <- function(...) {
num <- suppressWarnings(as.numeric(...))
if (is.na(num) || num < 0) {
num <- 0
} else if (num > 1) {
num <- 1
}
return(num)
}
# check hexadecimal character string
CheckColorStr <- function(txt) {
txt <- as.character(txt)
if (is.transparent)
txt <- substring(txt, 1, 9)
else
txt <- substring(txt, 1, 7)
sep.txt <- strsplit(txt, "")[[1]]
idxs <- which(vapply(sep.txt, function(i) i %in% hex.digits, TRUE))
txt <- paste(sep.txt[idxs], collapse="")
return(txt)
}
# update based on change in scales
ScaleH <- function(...) {
nh <<- as.numeric(...)
tclvalue(h.scl.var) <- nh
tclvalue(h.ent.var) <- sprintf("%.2f", nh)
ChangeColor(Hsv2hex(), is.hsva=TRUE)
}
ScaleS <- function(...) {
ns <<- as.numeric(...)
tclvalue(s.scl.var) <- ns
tclvalue(s.ent.var) <- sprintf("%.2f", ns)
ChangeColor(Hsv2hex(), is.hsva=TRUE)
}
ScaleV <- function(...) {
nv <<- as.numeric(...)
tclvalue(v.scl.var) <- nv
tclvalue(v.ent.var) <- sprintf("%.2f", nv)
ChangeColor(Hsv2hex(), is.hsva=TRUE)
}
ScaleA <- function(...) {
na <<- as.numeric(...)
tclvalue(a.ent.var) <- sprintf("%.2f", na)
tclvalue(col.var) <- Hsv2hex()
}
# update based on change in numeric color attributes
EntryH <- function() {
txt <- tclvalue(h.ent.var)
nh <<- CheckColorNum(txt)
tclvalue(h.scl.var) <- nh
ChangeColor(Hsv2hex(), is.hsva=TRUE)
}
EntryS <- function() {
txt <- tclvalue(s.ent.var)
ns <<- CheckColorNum(txt)
tclvalue(s.scl.var) <- ns
ChangeColor(Hsv2hex(), is.hsva=TRUE)
}
EntryV <- function() {
txt <- tclvalue(v.ent.var)
nv <<- CheckColorNum(txt)
tclvalue(v.scl.var) <- nv
ChangeColor(Hsv2hex(), is.hsva=TRUE)
}
EntryA <- function() {
txt <- tclvalue(a.ent.var)
na <<- CheckColorNum(txt)
tclvalue(a.scl.var) <- na
tclvalue(col.var) <- Hsv2hex()
}
# toggle transparency check-box
ToggleTransparency <- function() {
is.transparent <<- as.logical(as.integer(tclvalue(trans.var)))
if (is.transparent) {
tkconfigure(f3.lab.4.1, state="noraml")
tcl(f3.scl.4.2, "state", "!disabled")
tkconfigure(f3.ent.4.3, state="noraml")
} else {
tkconfigure(f3.lab.4.1, state="disabled")
tcl(f3.scl.4.2, "state", "disabled")
tkconfigure(f3.ent.4.3, state="disabled")
}
tclvalue(col.var) <- Hsv2hex()
}
# edit color entry
EditColorEntry <- function() {
txt <- CheckColorStr(tclvalue(col.var))
tclvalue(col.var) <- txt
col.hex <- Txt2hex(txt)
ChangeColor(col.hex, is.color=TRUE)
}
# require colorspace package
if (!requireNamespace("colorspace", quietly=TRUE)) stop()
# color chart information
m <- 12
dx <- dy <- 20
d1 <- cbind(colorspace::rainbow_hcl(m), colorspace::heat_hcl(m),
colorspace::terrain_hcl(m), rev(grDevices::gray.colors(m, start=0.1, end=0.9, gamma=1.0)))
d2 <- c("#000000", "#000033", "#000066", "#000099", "#0000CC", "#0000FF",
"#990000", "#990033", "#990066", "#990099", "#9900CC", "#9900FF",
"#003300", "#003333", "#003366", "#003399", "#0033CC", "#0033FF",
"#993300", "#993333", "#993366", "#993399", "#9933CC", "#9933FF",
"#006600", "#006633", "#006666", "#006699", "#0066CC", "#0066FF",
"#996600", "#996633", "#996666", "#996699", "#9966CC", "#9966FF",
"#009900", "#009933", "#009966", "#009999", "#0099CC", "#0099FF",
"#999900", "#999933", "#999966", "#999999", "#9999CC", "#9999FF",
"#00CC00", "#00CC33", "#00CC66", "#00CC99", "#00CCCC", "#00CCFF",
"#99CC00", "#99CC33", "#99CC66", "#99CC99", "#99CCCC", "#99CCFF",
"#00FF00", "#00FF33", "#00FF66", "#00FF99", "#00FFCC", "#00FFFF",
"#99FF00", "#99FF33", "#99FF66", "#99FF99", "#99FFCC", "#99FFFF",
"#330000", "#330033", "#330066", "#330099", "#3300CC", "#3300FF",
"#CC0000", "#CC0033", "#CC0066", "#CC0099", "#CC00CC", "#CC00FF",
"#333300", "#333333", "#333366", "#333399", "#3333CC", "#3333FF",
"#CC3300", "#CC3333", "#CC3366", "#CC3399", "#CC33CC", "#CC33FF",
"#336600", "#336633", "#336666", "#336699", "#3366CC", "#3366FF",
"#CC6600", "#CC6633", "#CC6666", "#CC6699", "#CC66CC", "#CC66FF",
"#339900", "#339933", "#339966", "#339999", "#3399CC", "#3399FF",
"#CC9900", "#CC9933", "#CC9966", "#CC9999", "#CC99CC", "#CC99FF",
"#33CC00", "#33CC33", "#33CC66", "#33CC99", "#33CCCC", "#33CCFF",
"#CCCC00", "#CCCC33", "#CCCC66", "#CCCC99", "#CCCCCC", "#CCCCFF",
"#33FF00", "#33FF33", "#33FF66", "#33FF99", "#33FFCC", "#33FFFF",
"#CCFF00", "#CCFF33", "#CCFF66", "#CCFF99", "#CCFFCC", "#CCFFFF",
"#660000", "#660033", "#660066", "#660099", "#6600CC", "#6600FF",
"#FF0000", "#FF0033", "#FF0066", "#FF0099", "#FF00CC", "#FF00FF",
"#663300", "#663333", "#663366", "#663399", "#6633CC", "#6633FF",
"#FF3300", "#FF3333", "#FF3366", "#FF3399", "#FF33CC", "#FF33FF",
"#666600", "#666633", "#666666", "#666699", "#6666CC", "#6666FF",
"#FF6600", "#FF6633", "#FF6666", "#FF6699", "#FF66CC", "#FF66FF",
"#669900", "#669933", "#669966", "#669999", "#6699CC", "#6699FF",
"#FF9900", "#FF9933", "#FF9966", "#FF9999", "#FF99CC", "#FF99FF",
"#66CC00", "#66CC33", "#66CC66", "#66CC99", "#66CCCC", "#66CCFF",
"#FFCC00", "#FFCC33", "#FFCC66", "#FFCC99", "#FFCCCC", "#FFCCFF",
"#66FF00", "#66FF33", "#66FF66", "#66FF99", "#66FFCC", "#66FFFF",
"#FFFF00", "#FFFF33", "#FFFF66", "#FFFF99", "#FFFFCC", "#FFFFFF")
d2 <- matrix(d2, nrow=m, ncol=length(d2) / m)
d <- cbind(d1, d2)
n <- ncol(d)
w <- dx * n
h <- dy * m
# all possible digits in color character string
hex.digits <- list(0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
"a", "b", "c", "d", "e", "f",
"A", "B", "C", "D", "E", "F", "#")
# initialize return color
rtn.col <- NULL
# initialize color ramp palette
col.ramp <- NULL
# account for improper color argument
if (missing(col) || !inherits(col, "character")) col <- "#000000"
# transparency status
is.transparent <- ifelse(nchar(col) == 9, TRUE, FALSE)
# color is intially required to be in hexadecimal format
col.hex <- Txt2hex(col)
# initialize hue, saturation, value, and alpha color components
col.rgb <- grDevices::col2rgb(col.hex, alpha=TRUE)
col.hsv <- grDevices::rgb2hsv(col.rgb[seq_len(3)], maxColorValue=255)
nh <- col.hsv[1]
ns <- col.hsv[2]
nv <- col.hsv[3]
na <- col.rgb[4] / 255
# assign additional variables linked to Tk widgets
col.var <- tclVar(col.hex)
trans.var <- tclVar(is.transparent)
h.scl.var <- tclVar(nh)
s.scl.var <- tclVar(ns)
v.scl.var <- tclVar(nv)
a.scl.var <- tclVar(na)
h.ent.var <- tclVar(sprintf("%.2f", nh))
s.ent.var <- tclVar(sprintf("%.2f", ns))
v.ent.var <- tclVar(sprintf("%.2f", nv))
a.ent.var <- tclVar(sprintf("%.2f", na))
tt.done.var <- tclVar(0)
# open gui
tclServiceMode(FALSE)
tt <- tktoplevel()
if (!is.null(parent)) {
tkwm.transient(tt, parent)
geo <- unlist(strsplit(as.character(tkwm.geometry(parent)), "\\+"))
geo <- as.integer(geo[2:3]) + 25
tkwm.geometry(tt, sprintf("+%s+%s", geo[1], geo[2]))
}
tkwm.resizable(tt, 0, 0)
tktitle(tt) <- "Choose Color"
# frame 0, ok and cancel buttons, and sample color
f0 <- ttkframe(tt, relief="flat")
f0.cvs.1 <- tkcanvas(f0, relief="flat", width=dx - 1, height=dy - 1,
background="white", confine=TRUE, closeenough=0,
borderwidth=0, highlightthickness=0)
f0.ent.2 <- ttkentry(f0, textvariable=col.var, width=12)
f0.chk.3 <- ttkcheckbutton(f0, variable=trans.var, text="Transparency",
command=ToggleTransparency)
f0.but.5 <- ttkbutton(f0, width=12, text="OK", command=SaveColor)
f0.but.6 <- ttkbutton(f0, width=12, text="Cancel",
command=function() {
rtn.col <<- NULL
tclvalue(tt.done.var) <- 1
})
tkgrid(f0.cvs.1, f0.ent.2, f0.chk.3, "x", f0.but.5, f0.but.6, pady=c(10, 10))
tkgrid.columnconfigure(f0, 3, weight=1)
tkgrid.configure(f0.cvs.1, sticky="w", padx=c(11, 1), pady=11)
tkgrid.configure(f0.ent.2, padx=c(4, 4))
tkgrid.configure(f0.but.5, sticky="e", padx=c(0, 4))
tkgrid.configure(f0.but.6, sticky="w", padx=c(0, 10), rowspan=2)
tkpack(f0, fill="x", side="bottom", anchor="e")
# frame 1, color chart
f1 <- ttkframe(tt, relief="flat")
f1.cvs <- tkcanvas(f1, relief="flat", width=w + 1, height=h + 1,
background="black", confine=TRUE, closeenough=0,
borderwidth=0, highlightthickness=0)
tkgrid(f1.cvs, padx=10, pady=10)
tkpack(f1)
# frame 2, color ramp
f2 <- ttkframe(tt, relief="flat")
f2.cvs <- tkcanvas(f2, relief="flat", width=w + 1, height=dy / 2 + 1,
background="black", confine=TRUE, closeenough=0,
borderwidth=0, highlightthickness=0)
tkgrid(f2.cvs, padx=10, pady=c(0, 10))
tkpack(f2)
# frame 3, color attriubte sliders
f3 <- ttkframe(tt, relief="flat")
f3.lab.1.1 <- ttklabel(f3, text="H", justify="center")
f3.lab.2.1 <- ttklabel(f3, text="S", justify="center")
f3.lab.3.1 <- ttklabel(f3, text="V", justify="center")
f3.lab.4.1 <- ttklabel(f3, text="A", justify="center")
f3.scl.1.2 <- tkwidget(f3, "ttk::scale", from=0, to=1,
orient="horizontal", value=nh, variable=h.scl.var,
command=function(...) ScaleH(...))
f3.scl.2.2 <- tkwidget(f3, "ttk::scale", from=0, to=1,
orient="horizontal", value=ns, variable=s.scl.var,
command=function(...) ScaleS(...))
f3.scl.3.2 <- tkwidget(f3, "ttk::scale", from=0, to=1,
orient="horizontal", value=nv, variable=v.scl.var,
command=function(...) ScaleV(...))
f3.scl.4.2 <- tkwidget(f3, "ttk::scale", from=0, to=1,
orient="horizontal", value=na, variable=a.scl.var,
command=function(...) ScaleA(...))
f3.ent.1.3 <- ttkentry(f3, textvariable=h.ent.var, width=4)
f3.ent.2.3 <- ttkentry(f3, textvariable=s.ent.var, width=4)
f3.ent.3.3 <- ttkentry(f3, textvariable=v.ent.var, width=4)
f3.ent.4.3 <- ttkentry(f3, textvariable=a.ent.var, width=4)
ToggleTransparency()
tkgrid(f3.lab.1.1, f3.scl.1.2, f3.ent.1.3, pady=c(0, 5))
tkgrid(f3.lab.2.1, f3.scl.2.2, f3.ent.2.3, pady=c(0, 5))
tkgrid(f3.lab.3.1, f3.scl.3.2, f3.ent.3.3, pady=c(0, 5))
tkgrid(f3.lab.4.1, f3.scl.4.2, f3.ent.4.3)
tkgrid.configure(f3.lab.1.1, f3.lab.2.1, f3.lab.3.1, f3.lab.4.1, padx=c(10, 2))
tkgrid.configure(f3.scl.1.2, f3.scl.2.2, f3.scl.3.2, f3.scl.4.2, sticky="we", padx=2)
tkgrid.configure(f3.ent.1.3, f3.ent.2.3, f3.ent.3.3, f3.ent.4.3, padx=c(10, 10))
tkgrid.columnconfigure(f3, 1, weight=1)
tkpack(f3, fill="x")
# initial commands
BuildColorChart()
ChangeColor(col.hex)
# bind events
tclServiceMode(TRUE)
tkbind(tt, "<Destroy>", function() tclvalue(tt.done.var) <- 1)
tkbind(f0.ent.2, "<KeyRelease>", EditColorEntry)
tkbind(f0.ent.2, "<Return>", SaveColor)
tkbind(f1.cvs, "<ButtonPress>", function(x, y) SelectChartColor(x, y))
tkbind(f2.cvs, "<ButtonPress>", function(x) SelectRampColor(x))
tkbind(f3.ent.1.3, "<KeyRelease>", EntryH)
tkbind(f3.ent.2.3, "<KeyRelease>", EntryS)
tkbind(f3.ent.3.3, "<KeyRelease>", EntryV)
tkbind(f3.ent.4.3, "<KeyRelease>", EntryA)
# gui control
tkfocus(tt)
tkgrab(tt)
tkwait.variable(tt.done.var)
tclServiceMode(FALSE)
tkgrab.release(tt)
tkdestroy(tt)
tclServiceMode(TRUE)
return(rtn.col)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.