1#' Graphical User Interface for Choosing HCL Color Palettes 2#' 3#' A graphical user interface (GUI) for viewing, manipulating, and choosing HCL 4#' color palettes. 5#' 6#' Computes palettes based on the HCL (hue-chroma-luminance) color model (as 7#' implemented by \code{\link{polarLUV}}). The GUIs interface the palette 8#' functions \code{\link{qualitative_hcl}} for qualitative palettes, 9#' \code{\link{sequential_hcl}} for sequential palettes with a single or 10#' multiple hues, and \code{\link{diverging_hcl}} for diverging palettes (composed 11#' from two single-hue sequential palettes). 12#' 13#' Two different GUIs are implemented and can be selected using the function 14#' input argument \code{gui} (\code{"tcltk"} or \code{"shiny"}). Both GUIs 15#' allows for interactive modification of the arguments of the respective 16#' palette-generating functions, i.e., starting/ending hue (wavelength, type of 17#' color), minimal/maximal chroma (colorfulness), minimal maximal luminance 18#' (brightness, amount of gray), and a power transformations that control how 19#' quickly/slowly chroma and/or luminance are changed through the palette. 20#' Subsets of the parameters may not be applicable depending on the type of 21#' palette chosen. See \code{\link{qualitative_hcl}} and Zeileis et al. (2009, 2019) for 22#' a more detailed explanation of the different arguments. Stauffer et al. 23#' (2015) provide more examples and guidance. 24#' 25#' Optionally, active palette can be illustrated by using a range of examples 26#' such as a map, heatmap, scatter plot, perspective 3D surface etc. 27#' 28#' To demonstrate different types of deficiencies, the active palette may be 29#' desaturated (emulating printing on a grayscale printer) and collapsed to 30#' emulate different types of color-blindness (without red-green or green-blue 31#' contrasts) using the \code{\link{simulate_cvd}} functions. 32#' 33#' \code{choose_palette} by default starts the Tcl/Tk version of the GUI while 34#' \code{hclwizard} by default starts the shiny version. \code{hcl_wizard} is 35#' an alias for \code{hclwizard}. 36#' 37#' @param pal function; the initial palette, see \sQuote{Value} below. Only 38#' used if \code{gui = "tcltk"}. 39#' @param n integer; the initial number of colors in the palette. 40#' @param parent tkwin; the GUI parent window. Only used if \code{gui = 41#' "tcltk"}. 42#' @param gui character; GUI to use. Available options are \code{tcltk} and 43#' \code{shiny}, see \sQuote{Details} below. 44#' @param ... used for development purposes only. 45#' @return Returns a palette-generating function with the selected arguments. 46#' Thus, the returned function takes an integer argument and returns the 47#' corresponding number of HCL colors by traversing HCL space through 48#' interpolation of the specified hue/chroma/luminance/power values. 49#' @author Jason C. Fisher, Reto Stauffer, Achim Zeileis 50#' @seealso \code{\link{simulate_cvd}}, \code{\link{desaturate}}, \code{\link{qualitative_hcl}}. 51#' @references Zeileis A, Hornik K, Murrell P (2009). Escaping RGBland: 52#' Selecting Colors for Statistical Graphics. \emph{Computational Statistics & 53#' Data Analysis}, \bold{53}, 3259--3270. 54#' \doi{10.1016/j.csda.2008.11.033} 55#' Preprint available from 56#' \url{https://www.zeileis.org/papers/Zeileis+Hornik+Murrell-2009.pdf}. 57#' 58#' Stauffer R, Mayr GJ, Dabernig M, Zeileis A (2015). Somewhere over the 59#' Rainbow: How to Make Effective Use of Colors in Meteorological 60#' Visualizations. \emph{Bulletin of the American Meteorological Society}, 61#' \bold{96}(2), 203--216. 62#' \doi{10.1175/BAMS-D-13-00155.1} 63#' 64#' Zeileis A, Fisher JC, Hornik K, Ihaka R, McWhite CD, Murrell P, Stauffer R, Wilke CO (2020). 65#' \dQuote{colorspace: A Toolbox for Manipulating and Assessing Colors and Palettes.} 66#' \emph{Journal of Statistical Software}, \bold{96}(1), 1--49. \doi{10.18637/jss.v096.i01} 67#' @keywords misc 68#' @examples 69#' if(interactive()) { 70#' ## Using tcltk GUI 71#' pal <- choose_palette() 72#' ## or equivalently: hclwizard(gui = "tcltk") 73#' 74#' ## Using shiny GUI 75#' pal <- hclwizard() 76#' ## or equivalently: choose_palette(gui = "shiny") 77#' 78#' ## use resulting palette function 79#' filled.contour(volcano, color.palette = pal, asp = 1) 80#' } 81#' @importFrom grDevices dev.cur dev.list dev.new dev.off dev.set 82 83#' @export 84choose_palette <- function(pal = diverging_hcl, n = 7L, parent = NULL, gui = "tcltk", ...) { 85 args <- list("pal" = pal, "n" = n, "parent" = parent, ...) 86 gui <- match.arg(gui, c("tcltk", "shiny")) 87 do.call(sprintf("choose_palette_%s", gui), args) 88} 89 90#' @rdname choose_palette 91#' @export 92hclwizard <- function(n = 7L, gui = "shiny", ...) { 93 args <- list("n" = n, ...) 94 gui <- match.arg(gui, c("tcltk", "shiny")) 95 do.call(sprintf("choose_palette_%s", gui), args) 96} 97 98 99#' @rdname choose_palette 100#' @usage NULL 101#' @export 102hcl_wizard <- function(n = 7L, gui = "shiny", ...) 103 hclwizard(n = n, gui = gui, ...) 104 105# ------------------------------------------------------------------- 106# Environment for passing around internal information 107# ------------------------------------------------------------------- 108 109.colorspace_env <- new.env() 110 111.colorspace_get_info <- function(x = NULL) { 112 if(is.null(x)) return(as.list(.colorspace_env)) 113 x <- as.character(x)[1L] 114 return(.colorspace_env[[x]]) 115} 116 117.colorspace_set_info <- function(...) { 118 dots <- list(...) 119 if(is.null(names(dots))) { 120 stop("arguments must be named") 121 } else if(any(names(dots) == "")) { 122 warning("ignoring unnamed arguments") 123 dots <- dots[names != ""] 124 } 125 if(length(dots) > 0L) { 126 for(i in names(dots)) { 127 .colorspace_env[[i]] <- dots[[i]] 128 } 129 } 130 invisible(NULL) 131} 132 133.colorspace_set_info( 134 hclwizard_autohclplot = FALSE, 135 hclwizard_ninit = 7, 136 hclwizard_verbose = FALSE, 137 hclwizard_shiny.trace = FALSE 138) 139 140# Setting global variables to avoid notes during R CMD check 141utils::globalVariables(c("frame2.cvs.paloffset", 142 "frame2.cvs.palwidth", "type", 143 "dev.example", "ttreg.name", 144 "frame3.scl.1.2", "frame3.scl.2.2", "frame3.scl.3.2", "frame3.scl.4.2", 145 "frame3.scl.5.2", "frame3.scl.6.2", "frame3.scl.7.2", "frame3.scl.8.2", 146 "frame3.scl.9.2", "frame3.ent.1.3", "frame3.ent.2.3", "frame3.ent.3.3", 147 "frame3.ent.4.3", "frame3.ent.5.3", "frame3.ent.6.3", "frame3.ent.7.3", 148 "frame3.ent.8.3", "frame3.ent.9.3", "h1.ent.var", "h1.scl.var", "h2.ent.var", 149 "h2.scl.var", "c1.ent.var", "c1.scl.var", "cmax.ent.var", "cmax.scl.var", 150 "c2.ent.var", "c2.scl.var", "l1.ent.var", "l1.scl.var", "l2.ent.var", 151 "l2.scl.var", "p1.ent.var", "p1.scl.var", "p2.ent.var", "p2.scl.var")) 152 153 154# hclwizard shiny GUI for selecting color palette 155choose_palette_shiny <- function(pal, n = 7L, ...) { 156 157 # Requirements for shiny application 158 stopifnot(requireNamespace("shiny"), requireNamespace("shinyjs")) 159 appDir <- system.file("hclwizard", package = "colorspace") 160 if (appDir == "") 161 stop("Could not find hclwizard app directory. Try re-installing `colorspace`.", call. = FALSE) 162 # Start shiny 163 dots <- list(...) 164 .colorspace_set_info(hclwizard_aninit = n) 165 .colorspace_set_info(hclwizard_autohclplot = ifelse(is.null(dots$autohclplot), FALSE, as.logical(dots$autohclplot))) 166 .colorspace_set_info(hclwizard_shiny.trace = ifelse(is.null(dots$shiny.trace), FALSE, as.logical(dots$shiny.trace))) 167 options(shiny.trace = .colorspace_get_info("hclwizard_shiny.trace")) 168 pal <- shiny::runApp(appDir, display.mode = "normal", quiet = TRUE ) 169 return(pal) 170} 171 172# tcltk GUI for selecting a color palette 173choose_palette_tcltk <- function( pal = diverging_hcl, n=7L, parent = NULL, ... ) { 174 175 # Evaluate dots args 176 dots <- list(...) 177 .colorspace_set_info( 178 hclwizard_verbose = ifelse(is.null(dots$verbose), FALSE, as.logical(dots$verbose)), 179 hclwizard_autohclplot = ifelse(is.null(dots$autohclplot), FALSE, as.logical(dots$autohclplot)) 180 ) 181 182 # Choose a file interactively 183 ChooseFile <- function(cmd, win.title, initialfile=NULL, 184 defaultextension=NULL) { 185 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling ChooseFile\n")) 186 187 filetypes <- "{{R Source Files} {.R}} {{All files} {*}}" 188 if (cmd == "Open") { 189 args <- list("tk_getOpenFile") 190 } else { 191 args <- list("tk_getSaveFile") 192 if (defaultextension == ".txt") 193 filetypes <- "{{Text Files} {.txt}} {{All files} {*}}" 194 } 195 args[["title"]] <- win.title 196 args[["parent"]] <- tt 197 args[["initialdir"]] <- initialdir 198 args[["filetypes"]] <- filetypes 199 200 if (!is.null(initialfile)) 201 args[["initialfile"]] <- initialfile 202 if (!is.null(defaultextension)) 203 args[["defaultextension"]] <- defaultextension 204 205 f <- tcltk::tclvalue(do.call(tcltk::tcl, args)) 206 if (!nzchar(f)) return() 207 initialdir <<- dirname(f) 208 f 209 } 210 211 # Open palette from file 212 OpenPaletteFromFile <- function() { 213 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling OpenPaletteFromFile\n")) 214 215 f <- ChooseFile(cmd = "Open", win.title = "Open Palette File") 216 if (is.null(f)) return() 217 pal <- dget(file = f) 218 pal_args <- ConvertPaletteToAttributes(pal) 219 UpdateDataType() 220 AssignAttributesToWidgets(pal_args) 221 DrawPalette() 222 } 223 224 # Save palette to file 225 SavePaletteToFile <- function() { 226 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling SavePaletteToFile\n")) 227 228 f <- ChooseFile(cmd = "Save As", win.title = "Save Palette As", 229 initialfile = "color_palette", defaultextension = ".R") 230 if (is.null(f)) return() 231 args <- list("type" = as.character(tcltk::tclvalue(nature.var))) 232 for ( arg in vars.pal[!vars.pal %in% "type"] ) 233 args[[arg]] <- eval(parse(text=arg)) 234 # Adding reverse and fixup arguments 235 args$reverse <- reverse 236 args$fixup <- as.logical(as.integer(tcltk::tclvalue(fixup.var))) 237 pal <- do.call(GetPalette, args) 238 dput(pal, file=f) 239 } 240 241 # Save colors to file 242 SaveColorsToFile <- function(type) { 243 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling SaveColorsToFile\n")) 244 245 args <- list("type" = as.character(tcltk::tclvalue(nature.var))) 246 for ( arg in vars.pal[!vars.pal %in% "type"] ) 247 eval(parse(text=arg)) 248 # Adding reverse and fixup arguments 249 args$reverse <- reverse 250 args$fixup <- as.logical(as.integer(tcltk::tclvalue(fixup.var))) 251 pal <- do.call(GetPalette, args) 252 253 cols <- try(hex2RGB(pal(n)), silent=TRUE) 254 if (inherits(cols, "try-error")) { 255 msg <- "Palette results in invaild hexadecimal colors." 256 tcltk::tkmessageBox(icon="error", message=msg, title="Color Error", 257 parent=tt) 258 return() 259 } 260 261 f <- ChooseFile(cmd="Save As", win.title="Save Colors As", 262 initialfile=paste("colors_", type, sep=""), 263 defaultextension=".txt") 264 if (is.null(f)) return() 265 266 if (type == "HEX") { 267 writehex(cols, file=f) 268 } else { 269 if (type == "sRGB") { 270 cols <- as(cols, "sRGB")@coords 271 } else if (type == "HSV") { 272 cols <- as(cols, "HSV")@coords 273 } else if (type == "HCL") { 274 cols <- as(cols, "polarLUV")@coords 275 } else if (type == "CMYK") { 276 cols <- as(cols, "RGB")@coords 277 red <- cols[, "R"] 278 green <- cols[, "G"] 279 blue <- cols[, "B"] 280 black <- sapply(1:n, function(i) min(c(1 - red[i], 281 1 - green[i], 282 1 - blue[i]))) 283 cyan <- (1 - red - black) / (1 - black) 284 magenta <- (1 - green - black) / (1 - black) 285 yellow <- (1 - blue - black) / (1 - black) 286 cols <- as.matrix(as.data.frame(list(C=cyan, M=black, 287 Y=yellow, K=black))) 288 } 289 utils::write.table(cols, file=f, quote=FALSE, row.names=FALSE, sep="\t") 290 } 291 } 292 293 # Save palette and quit 294 SavePalette <- function() { 295 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling SavePalette\n")) 296 297 args <- list("type" = as.character(tcltk::tclvalue(nature.var))) 298 for ( arg in vars.pal[!vars.pal %in% "type"] ) 299 args[[arg]] <- eval(parse(text=arg)) 300 # Adding reverse and fixup arguments 301 args$reverse <- reverse 302 args$fixup <- as.logical(as.integer(tcltk::tclvalue(fixup.var))) 303 pal.rtn <<- do.call(GetPalette, args) 304 tcltk::tclvalue(tt.done.var) <- 1 305 } 306 307 # Scale change 308 ScaleChange <- function(x, v, x.ent.var) { 309 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling ScaleChange\n")) 310 311 if (x == get(v)) return() 312 assign(v, x, inherits=TRUE) 313 fmt <- ifelse(v %in% c("p1", "p2"), "%.1f", "%.0f") 314 tcltk::tclvalue(x.ent.var) <- sprintf(fmt, x) 315 DrawPalette(v == "n") 316 } 317 318 # Entry change 319 EntryChange <- function(v, x.lim, x.ent.var, x.scl.var) { 320 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling EntryChange\n")) 321 322 x <- suppressWarnings(as.numeric(tcltk::tclvalue(x.ent.var))) 323 if (is.na(x)) 324 return() 325 if (x < x.lim[1]) { 326 tcltk::tclvalue(x.ent.var) <- x.lim[1] 327 x <- x.lim[1] 328 } else if (x > x.lim[2]) { 329 tcltk::tclvalue(x.ent.var) <- x.lim[2] 330 x <- x.lim[2] 331 } 332 assign(v, x, inherits=TRUE) 333 tcltk::tclvalue(x.scl.var) <- x 334 DrawPalette(v == "n") 335 } 336 337 # Helper function to create the hex palettes. 338 # Generates "n" colors from palette "pal" and manipulates them 339 # if desaturation or CVD simulation is required. 340 get_hex_colors <- function(pal,n) { 341 fixup <- as.logical(as.numeric(tcltk::tclvalue(fixup.var))) 342 pal.cols <- pal(n, fixup = fixup) 343 if (as.logical(as.integer(tcltk::tclvalue(desaturation.var)))) 344 pal.cols <- desaturate(pal.cols) 345 if (as.logical(as.integer(tcltk::tclvalue(colorblind.var)))) { 346 type <- as.character(tcltk::tclvalue(colorblind.type.var)) 347 pal.cols <- do.call(type,list("col"=pal.cols)) 348 } 349 pal.cols 350 } 351 352 # Draw current palette given the slider settings. Fills the 353 # canvas object placed horizontally in the lower part of the GUI. 354 # is.n is TRUE if the slider for "n" is moved. Else FALSE. IF 355 # FALSE the "selected default color palette" polygon ("browse") 356 # will be removed. 357 DrawPalette <- function(is.n = FALSE) { 358 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling DrawPalette\n")) 359 360 args <- list("type" = as.character(tcltk::tclvalue(nature.var))) 361 for ( arg in vars.pal[!vars.pal %in% "type"] ) 362 args[[arg]] <- eval(parse(text=arg)) 363 # Adding reverse and fixup arguments 364 args$reverse <- reverse 365 args$fixup <- as.logical(as.integer(tcltk::tclvalue(fixup.var))) 366 367 if ( ! is.n ) tcltk::tcl(frame2.cvs, "delete", "browse") 368 pal <- do.call(GetPalette, args) 369 tcltk::tcl(frame7.cvs, "delete", "pal") 370 371 pal.cols <- get_hex_colors(pal, n) 372 dx <- (cvs.width - 1) / n 373 x2 <- 1 374 y1 <- 1 375 y2 <- cvs.height 376 # NA color (white or black, depending on darkmode.var) 377 NAcolor <- ifelse(tcltk::tclvalue(darkmode.var) != "1", "#FFFFFF", "#000000") 378 for (color in pal.cols) { 379 color <- ifelse(is.na(color), NAcolor, color) 380 x1 <- x2 381 x2 <- x1 + dx 382 pts <- tcltk::.Tcl.args(c(x1, y1, x2, y1, x2, y2, x1, y2)) 383 tcltk::tkcreate(frame7.cvs, "polygon", pts, fill = color, tag = "pal") 384 } 385 RegenExample(pal,n) 386 } 387 388 # Update data type 389 # @param ... used when called via callback. 390 # @param init logical. Default is FALSE, if set to TRUE the first default 391 # palette of the current palette config is used. Only used when initializing 392 # the GUI. 393 frame2.cvs.paloffset <- frame2.cvs.palwidth <- NULL 394 UpdateDataType <- function(..., init = FALSE) { 395 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling UpdateDataType\n")) 396 tcltk::tcl(frame2.cvs, "delete", "browse") 397 398 # Default palettes to data.frame 399 pals_to_dataframe <- function(x) { 400 x <- as.data.frame(t(as.matrix(sapply(x, function(x) x), ncol = length(x)))) 401 names(x) <- vars.pal 402 x$reverse <- FALSE 403 return(x) 404 } 405 type <- as.character(tcltk::tclvalue(nature.var)) 406 407 # Loading default palettes via GetPaletteConfig 408 palettes <- GetPaletteConfig(gui = TRUE) 409 names(palettes) <- tolower(names(palettes)) 410 palettes$fixup <- TRUE 411 palettes$reverse <- FALSE 412 413 if (type == "Basic: Qualitative") { 414 default.pals <<- subset(palettes, type == "qual") 415 416 } else if ( type == "Basic: Sequential (single-hue)" ) { 417 default.pals <<- subset(palettes, type == "seqs") 418 419 } else if ( type == "Advanced: Sequential (single-hue)" ) { 420 default.pals <<- subset(palettes, type == "seqs_advanced") 421 422 } else if (type == "Basic: Sequential (multi-hue)") { 423 default.pals <<- subset(palettes, type == "seqm") 424 425 } else if (type == "Advanced: Sequential (multi-hue)") { 426 default.pals <<- subset(palettes, type == "seqm_advanced") 427 428 } else if (type == "Basic: Diverging") { 429 default.pals <<- subset(palettes, type == "dive") 430 431 } else if (type == "Advanced: Diverging") { 432 default.pals <<- subset(palettes, type == "dive_advanced") 433 434 } 435 436 # Default palettes. Draws the canvas placed vertically side by side 437 # in the upper part of the GUI. 438 tcltk::tcl(frame2.cvs, "delete", "default") 439 # Offset and width of the default palettes. 440 frame2.cvs.paloffset <<- 3 441 frame2.cvs.palwidth <<- 380 / (nrow(default.pals)) - 2 * frame2.cvs.paloffset 442 frame2.cvs.palwidth <<- max(10, min(30 + 2 * frame2.cvs.paloffset, frame2.cvs.palwidth)) 443 x1 <- frame2.cvs.paloffset # Start with one offset 444 for (i in 1:nrow(default.pals)) { 445 # Create numeric palette parameter list, drop name 446 args <- as.list(default.pals[i,]) 447 args <- args[which(! names(args) %in% c("name", "gui"))] 448 args$type <- as.character(tcltk::tclvalue(nature.var)) 449 args$reverse <- FALSE 450 args$fixup <- as.logical(as.integer(tcltk::tclvalue(fixup.var))) 451 args$register <- "" 452 453 pal <- do.call(GetPalette, args=args) 454 pal.cols <- pal(5) 455 pal.cols[is.na(pal.cols)] <- "#FFFFFF" # Use white for NA colors (if fixup = FALSE) 456 y2 <- frame2.cvs.paloffset 457 458 for (j in pal.cols) { 459 x2 <- x1 + frame2.cvs.palwidth 460 y1 <- y2 461 y2 <- y1 + (70 - 2*frame2.cvs.paloffset) / length(pal.cols) 462 # Plading the tk element 463 pts <- tcltk::.Tcl.args(c(x1, y1, x2, y1, x2, y2, x1, y2)) 464 tcltk::tkcreate(frame2.cvs, "polygon", pts, fill=j, tag="default") 465 } 466 467 if ( i == 1 ) { 468 y1 <- frame2.cvs.paloffset 469 y2 <- y1 + 70 - 2*frame2.cvs.paloffset 470 pts <- tcltk::.Tcl.args(c(x1 - 2, y1 - 2, x2 + 1, y1 - 2, x2 + 1, y2 + 1, x1 - 2, y2 + 1)) 471 tcltk::tkcreate(frame2.cvs, "polygon", pts, fill = "", outline = "black", tag = "browse") 472 } 473 474 # Increase x1 475 x1 <- x1 + frame2.cvs.palwidth + 2 * frame2.cvs.paloffset 476 } 477 478 # Use first default palette as default 479 if ( init ) AssignAttributesToWidgets(as.list(default.pals[1,])) 480 DrawPalette(TRUE) 481 } 482 483 # Select default palette 484 # Triggered when the user clicks one of our default palettes. 485 SelectDefaultPalette <- function(x, y) { 486 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling SelectDefaultPalette\n")) 487 488 # Position within tcltk object 489 x <- as.numeric(x) 490 y <- as.numeric(y) 491 if (is.na(x) | is.na(y)) return() 492 493 y1 <- frame2.cvs.paloffset; y2 <- 70 - frame2.cvs.paloffset 494 if (y < y1 | y > y2) return() 495 496 # max.x: width of the whole selectable area 497 max.x <- nrow(default.pals) * (frame2.cvs.palwidth + 2 * frame2.cvs.paloffset) 498 if (x < 0 | x > max.x) return() 499 x.seq <- seq(0, max.x, by = frame2.cvs.palwidth + 2 * frame2.cvs.paloffset) 500 501 # Getting palette arguments 502 i <- findInterval(x, x.seq, rightmost.closed=TRUE) 503 pal_args <- as.list(default.pals[i,]) 504 505 # Draw black frame around the selected palette 506 x1 <- x.seq[i] 507 x2 <- x.seq[i + 1] 508 for ( key in vars[!vars %in% c("name", "type", "gui")] ) { 509 val <- as.numeric(pal_args[[key]]) 510 if ( is.na(val) ) val <- 0 511 #cat(sprintf("- Assign %-10s", key)); print(val) 512 assign(key, val, inherits=TRUE) 513 } 514 AssignAttributesToWidgets(pal_args) 515 DrawPalette() 516 517 # Assign new palette attributes/settings to the slider elements 518 tcltk::tcl(frame2.cvs, "delete", "browse") 519 pts <- tcltk::.Tcl.args(c(x1 + 1, y1 - 2, x2 - 2, y1 - 2, x2 - 2, y2 + 1, x1 + 1, y2 + 1)) 520 tcltk::tkcreate(frame2.cvs, "polygon", pts, fill = "", outline = "black", tag = "browse") 521 } 522 523 524 # Convert palette to attributes 525 ConvertPaletteToAttributes <- function(pal) { 526 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling ConvertPaletteToAttributes\n")) 527 528 # If input was missing or NULL, take a default sequential 529 # multi hue palette (the first in the GetPaletteConfig data.frame) 530 if ( missing(pal) | is.null(pal) ) { 531 532 tcltk::tclvalue(nature.var) <- "Basic: Sequential (multi-hue)" 533 pal_args <- GetPaletteConfig(gui = TRUE) 534 pal_args <- as.list(subset(pal_args, type == "seqm")[1,]) 535 names(pal_args) <- tolower(names(pal_args)) 536 537 # Take arguments from function input, if set 538 } else if (inherits(pal, "function")) { 539 540 arg <- sapply(formals(pal), function(i) {if (is.call(i)) eval(i) else i}) 541 542 # List to take up the palette parameters 543 pal_args <- list("n" = 7) 544 545 # De-parsing h, c, l, power to (h1, h2), (c1, c2), (l1, l2), (p1, p2) 546 # Overwrite the NA defaults (if set) 547 if ( length(arg$h) > 0 ) { 548 for ( i in seq_along(arg$h) ) 549 eval(parse(text = sprintf("pal_args$h%1$d <- arg$h[%1$dL]", i))) 550 } 551 # For c1/cmax/c2 we need a bit of custom code. For different palette types 552 # the "c" handling is different. 553 # - Qualitative: they only have a single-element "c" (easy) 554 # - Sequential single hue: c can be a c(c1) or c(c1, cmax) 555 # - Sequential multi hue: c can be a c(c1, c2) or c(c1, c2, cmax) 556 # - Diverging: c can be a c(c1) or c(c1, cmax) 557 # Thus, diverging_hcl "advanced" and sequential multi hue "not advanced" 558 # can look very similar given there default arguments, e.g.,: 559 # - diverging_hcl(n = 7, h = c(0, 100), c = c(50, 70), l = c(40, 90)) 560 # - sequential_hcl(n = 7, h = c(0, 100), c = c(50, 70), l = c(40, 90)) 561 # When loading a palette we do not get the function name, only the function 562 # arguments (via formals). Do be able to distinguish between these two 563 # types the diverging_hcl "advanced" stores a "cmax" in addition. Thus, 564 # if we have a chroma vector of length 2 PLUS a cmax which maches c[2L] 565 # we assume we have a diverging "advanced" palette and have to split 566 # the arguments in a different way. 567 # 568 # Sequential multi hue advanced with c(c1, c2, cmax) 569 if ( length(arg$c) >= 3 ) { 570 pal_args$c1 <- arg$c[1L] 571 pal_args$cmax <- arg$c[2L] 572 pal_args$c2 <- arg$c[3L] 573 # Diverging advanced with c(c1, cmax) and c[2L] == cmax 574 } else if ( length(arg$c == 2 & arg$c[2L] == arg$cmax) ) { 575 pal_args$c1 <- arg$c[1L] 576 pal_args$cmax <- arg$c[2L] 577 # Else sequential multi hue (not advanced) 578 } else if ( length(arg$c) > 0 ) { 579 for ( i in seq(1, length(arg$c)) ) 580 eval(parse(text = sprintf("pal_args$c%1$d <- arg$c[%1$dL]", i))) 581 } 582 if ( length(arg$l) > 0 ) { 583 for ( i in seq_along(arg$l) ) 584 eval(parse(text = sprintf("pal_args$l%1$d <- arg$l[%1$dL]", i))) 585 } 586 if ( length(arg$power) > 0 ) { 587 for ( i in seq_along(arg$power) ) 588 eval(parse(text = sprintf("pal_args$p%1$d <- arg$power[%1$dL]", i))) 589 } 590 if ( is.logical(arg$rev) ) 591 pal_args[["rev"]] <- arg$rev 592 # Fixup 593 if (! is.null(arg$fixup) && is.logical(arg$fixup)) 594 pal_args[["fixup"]] <- as.integer(arg$fixup) 595 else 596 pal_args[["fixup"]] <- 1 597 598 # Overrule settings with special arguments 599 for ( key in names(arg) ) { 600 if ( grepl("^([clh][12]|cmax)$", key) & ! is.null(arg[[key]]) ) 601 if ( ! inherits(arg[[key]], "name") ) pal_args[[key]] <- arg[[key]] 602 } 603 604 # If input is rainbow_hcl 605 rb.args <- c("c", "l", "start", "end") # args for qualitative palettes 606 if ( all(sapply(rb.args, function(i) inherits(arg[[i]], c("integer", "numeric")))) ) { 607 tcltk::tclvalue(nature.var) <- "Basic: Qualitative" 608 pal_args$h1 <- arg$start 609 pal_args$h2 <- arg$end 610 } 611 612 # If has no c2, l2, p1, p2, cmax -> qualitative 613 arg_names <- names(pal_args)[!is.na(pal_args)] 614 # Qualitative palettes: 615 # - Always NA: cmax, c2, l2, p1, p2 616 if ( all( ! c("cmax", "c2", "l2", "p1", "p2") %in% arg_names) ) { 617 pal_type <- "Basic: Qualitative" 618 # Sequential single hue 619 # - Always NA: h2, cmax, c2, p2 620 } else if ( all( ! c("h2", "cmax", "c2", "p2") %in% arg_names) ) { 621 pal_type <- "Basic: Sequential (single-hue)" 622 # Diverging 623 # - Always NA: cmax, c2 624 } else if ( all( ! c("cmax", "c2") %in% arg_names) ) { 625 pal_type <- "Basic: Diverging" 626 # Diverging, advanced 627 # - Always NA: c2, but have h1 and h2 628 } else if ( all(! c("c2") %in% arg_names) & all(c("h1", "h2") %in% arg_names )) { 629 pal_type <- "Advanced: Diverging" 630 # Sequential single hue, advanced 631 # - Always NA: h2 632 } else if ( all(! c("h2") %in% arg_names) ) { 633 pal_type <- "Advanced: Sequential (single-hue)" 634 # Sequential multi hue, advanced 635 # - Always NA: cmax 636 } else if ( ! "cmax" %in% arg_names ) { 637 pal_type <- "Basic: Sequential (multi-hue)" 638 # Else we expect it to be a sequential hulti hue, advanced 639 } else { 640 pal_type <- "Advanced: Sequential (multi-hue)" 641 } 642 tcltk::tclvalue(nature.var) <- pal_type 643 644 # Extending the palette args with NA's 645 for ( key in slider_elements ) 646 if ( ! key %in% names(pal_args) ) pal_args[[key]] <- NA 647 for ( key in names(pal_args) ) 648 if ( ! key %in% c("rev", slider_elements) ) pal_args[[key]] <- NULL # Remove 649 650 } else { 651 stop("Cannot interpret input palette in choose_palette") 652 } 653 654 # Return palette settings 655 return(pal_args) 656 } 657 658 659 # Assign attributes to widgets 660 # pal_args can be a named list with the settings of the 661 # current palette (e.g,. when the user selects a new default 662 # palette). If an element contains NA the corresponding 663 # slider will be disabled. 664 AssignAttributesToWidgets <- function(pal_args) { 665 if ( .colorspace_get_info("hclwizard_verbose") ) cat(sprintf("Calling AssignAttributesToWidgets\n")) 666 667 # Setting rev (reverse colors) if specified 668 if ( is.logical(pal_args$rev) ) { 669 tcltk::tclvalue(reverse.var) <- pal_args$rev 670 reverse <<- pal_args$rev 671 } 672 673 # Looping trouch slider elements 674 for ( i in seq_along(slider_elements) ) { 675 676 # Name of the slider element 677 key <- slider_elements[i] 678 679 # Format to set the current value 680 if ( key %in% c("name", "gui", "n") ) { 681 next 682 } else if ( grepl("^[hcl]", key) ) { 683 fmt <- "%.0f" 684 } else { 685 fmt <- "%.1f" 686 } 687 688 # If pal_args is given: check if value is.na. If NA: 689 # disable label, slider, and the text output element. 690 # Else enable. 691 if ( !missing(pal_args) ) { 692 state <- ifelse(is.na(pal_args[[key]]), FALSE, TRUE) 693 #cat(sprintf(" - Setting sliders t/f: %s %s", state, key)) 694 #cat(sprintf(" %s .... %.1f\n", key, pal_args[[key]])) 695 cmd <- sprintf("tcltk::tkconfigure(frame3.lab.%d.1, state = \"%s\")", 696 i, ifelse(state, "normal", "disabled")) 697 eval(parse(text = cmd)) 698 cmd <- sprintf("tcltk::tkconfigure(frame3.ent.%d.3, state = \"%s\")", 699 i, ifelse(state, "normal", "disabled")) 700 eval(parse(text = cmd)) 701 cmd <- sprintf("tcltk::tcl(frame3.scl.%d.2, \"state\", \"%s\")", 702 i, ifelse(state, "!disabled", "disabled")) 703 eval(parse(text = cmd)) 704 } 705 706 # Update slider range (c1/c2) if a palette with 707 # additional cmax has been selected by the user. 708 # In these cases we are setting: 709 # - c1 range of 0 - 180 710 # - c2 range of 0 - 180 711 if ( is.na(pal_args$cmax) ) { 712 for ( i in grep("^(c1|c2)$", slider_elements) ) { 713 # Reducing upper limit from 180 to 100: make 714 # sure the values are not above 100. If they are, 715 # set them to 100. 716 cmd <- sprintf("tcltk::tclvalue(%s.ent.var)", slider_elements[i]) 717 val <- eval(parse(text = cmd)) 718 val <- ifelse(val == "NA", NA, as.numeric(val)) 719 if ( ! is.na(val) && val > 100 ) { 720 eval(parse(text = sprintf("tcltk::tclvalue(%s.ent.var) <- 100", slider_elements[i]))) 721 eval(parse(text = sprintf("tcltk::tclvalue(%s.scl.var) <- 100", slider_elements[i]))) 722 } 723 cmd <- sprintf("tcltk::tkconfigure(frame3.scl.%d.2, to = %d)", i, 100) 724 eval(parse(text = cmd)) 725 } 726 } else { 727 for ( i in grep("^(c1|c2)$", slider_elements) ) { 728 cmd <- sprintf("tcltk::tkconfigure(frame3.scl.%d.2, to = %d)", i, 180) 729 eval(parse(text = cmd)) 730 } 731 } 732 733 734 # If attribute is NA: set to 0 735 #val <- ifelse(is.na(pal_args[[key]]), 0, pal_args[[key]]) 736 val <- pal_args[[key]] 737 738 # Set current value (slider and text output) 739 if ( is.na(val) ) { 740 cmd <- sprintf("tcltk::tclvalue(%1$s.ent.var) <- \"NA\"", key) 741 } else { 742 cmd <- sprintf("tcltk::tclvalue(%1$s.ent.var) <- sprintf(\"%2$s\", %3$.1f)", key, fmt, val) 743 } 744 eval(parse(text = cmd)) 745 cmd <- sprintf("tcltk::tclvalue(%1$s.scl.var) <- %2$.1f", key, val) 746 eval(parse(text = cmd)) 747 assign(key, val, inherits=TRUE) 748 } 749 750 } 751 752 # Open window to register a palette 753 RegisterPalette <- function(x) { 754 755 # New tcltk window (tktoplevel) 756 ttreg <- tcltk::tktoplevel() 757 758 # Loading geometry (sidze and position) of the main window 759 geo <- unlist(strsplit(as.character(tcltk::tkwm.geometry(tt)), "\\+")) 760 dim <- unlist(strsplit(geo[1L], "x")) 761 pos_x <- as.integer(geo[2L]) + (as.integer(dim[1L]) - 300) / 2 762 pos_y <- as.integer(geo[3L]) + 50 763 tcltk::tkwm.geometry(ttreg, sprintf("300x100+%.0f+%.0f", pos_x, pos_y)) 764 tcltk::tkwm.resizable(ttreg, 0, 0) 765 tcltk::tktitle(ttreg) <- "Register Custom Palette" 766 767 # Function registering the palette 768 reg_pal <- function() { 769 name <- tcltk::tclvalue(ttreg.name) 770 if ( nchar(name) > 0 ) { 771 args <- list("type" = as.character(tcltk::tclvalue(nature.var))) 772 for ( arg in vars.pal[!vars.pal %in% "type"] ) 773 args[[arg]] <- eval(parse(text=arg)) 774 args$reverse <- reverse 775 args$register <- name 776 args$fixup <- as.logical(as.integer(tcltk::tclvalue(fixup.var))) 777 # Loading palette with register = NAME 778 pal <- do.call(GetPalette, args) 779 # Evaluate/execute the function to register the new palette. 780 pal(1) 781 # Close Register-window 782 tcltk::tclvalue(ttreg.done.var) <- 1 783 } 784 } 785 786 # Adding text, text input, and register button. 787 ttreg.name <- tcltk::tclVar("") 788 reg_text <- tcltk::tklabel( ttreg, text = "Enter palette name:") 789 reg_name <- tcltk::ttkentry( ttreg, textvariable = ttreg.name, width = 12) 790 reg_btn <- tcltk::ttkbutton(ttreg, width=12, state = "disabled", 791 text="Register", command = reg_pal) 792 793 # Allow to close with Escape, register palette when pressing return, and 794 # the destroy functionality when pressing the "X" button. 795 tcltk::tkbind(ttreg, "<Escape>", function() tcltk::tclvalue(ttreg.done.var) <- 1) 796 tcltk::tkbind(ttreg, "<Return>", reg_pal) 797 tcltk::tkbind(ttreg, "<Destroy>", function() tcltk::tclvalue(ttreg.done.var) <- 1); 798 799 # Checking user name for the palette. Only allows alpha numeric values, 800 # blanks, dashes, and underscores. 801 check_name <- function() { 802 name <- unlist(strsplit(tcltk::tclvalue(ttreg.name), "")) 803 name <- paste(regmatches(name, regexpr("[A-Za-z\\_\\-\\s0-9]", 804 name, perl = T)), collapse = "") 805 tcltk::tclvalue(ttreg.name) <- name 806 if ( nchar(name) > 0 ) { 807 tcltk::tkconfigure(reg_btn, state = "normal") 808 } else { 809 tcltk::tkconfigure(reg_btn, state = "disabled") 810 } 811 } 812 tcltk::tkbind(reg_name, "<KeyRelease>", check_name) 813 814 815 # Add to window 816 #tcltk::tkgrid(reg_text, sticky = "w", padx = c(10,10), pady = c(10,10)) 817 #tcltk::tkgrid(reg_name, reg_btn, padx = c(10,10)) 818 tcltk::tkgrid(reg_text, sticky = "w", padx = c(10, 10), pady = c(10, 10)) 819 tcltk::tkgrid(reg_name, reg_btn) 820 tcltk::tkfocus(reg_name) 821 822 # GUI control 823 tcltk::tkgrab(ttreg) 824 tcltk::tkwait.variable(ttreg.done.var) 825 tcltk::tclServiceMode(FALSE) 826 tcltk::tkgrab.release(ttreg) 827 tcltk::tkdestroy(ttreg) 828 tcltk::tclServiceMode(TRUE) 829 } 830 831 832 # Show example plot 833 ShowExample <- function() { 834 if ( ! dev.example %in% dev.list() ) { 835 dev.new(width = 7L, height = 7L) 836 dev.example <<- dev.cur() 837 } 838 ExampleSetPar() 839 DrawPalette(is.n = TRUE) 840 } 841 842 ExampleSetPar <- function() { 843 if ( ! as.logical(as.numeric(tcltk::tclvalue(darkmode.var))) ) { 844 par(oma=c(0, 0, 0, 0), mar=c(0, 0, 0, 0)) 845 par(bg = "white", fg = "black", col.axis = "black") 846 } else { 847 par(mar = rep(1, 4)) 848 par(bg = "black", fg = "white", col.axis = "white") 849 } 850 } 851 852 ActivateDarkmode <- function() { 853 if (dev.example %in% dev.list()) dev.set(which = dev.example) 854 else return() 855 # If dark mode has been set off 856 # Draw palette, also regenerates example if open 857 ExampleSetPar() 858 DrawPalette() 859 } 860 861 # Regenerate example plot 862 RegenExample <- function(pal,n) { 863 if (dev.example %in% dev.list()) dev.set(which=dev.example) 864 else return() 865 plot_example <- eval(parse(text=sprintf("plot_%s", 866 gsub(" ", "", tolower(tcltk::tclvalue(example.var)))))) 867 # Spectrum plot: take 100 values (hardcoded) 868 if ( tcltk::tclvalue(example.var) == "Spectrum" ) n <- 100 869 pal.cols <- get_hex_colors(pal,n) 870 871 if ( grepl("^HCL\\sPlot$", as.character(tcltk::tclvalue(example.var))) & !.colorspace_get_info("hclwizard_autohclplot") ) { 872 type <- as.character(tcltk::tclvalue(nature.var)) 873 if ( grepl("[Dd]iverging", type) ) { type <- "diverging" } 874 else if ( grepl("[Ss]equential", type) ) { type <- "sequential" } 875 else if ( grepl("[Qq]ualitative", type) ) { type <- "qualitative" } 876 else { type <- NULL } 877 plot_example(pal.cols, type = type) 878 } else { 879 plot_example(pal.cols) 880 } 881 } 882 883 884 # ---------------------------------------------------------------- 885 # Main program 886 # ---------------------------------------------------------------- 887 888 # Initialize directory 889 initialdir <- getwd() 890 891 # Default 892 reverse <- FALSE 893 894 # Initialize return palette 895 pal.rtn <- NULL 896 897 # Initialize default palettes 898 default.pals <- NULL 899 900 # Initialize data for scatter plot example 901 xyhclust <- NULL 902 903 # Initialize data for mosaic plot example 904 msc.matrix <- NULL 905 906 # Flag graphics device 907 dev.example <- 1 908 909 # Set default and initial palettes 910 for ( key in vars.pal[!vars.pal %in% "type"] ) 911 eval(parse(text = sprintf("%s <- 0", key))) 912 fixup <- 1 913 914 # Load/Define palettes 915 vars <- vars.pal 916 qual.pals <- qual.pals 917 seqs.pals <- seqs.pals 918 seqm.pals <- seqm.pals 919 dive.pals <- dive.pals 920 921 # Set limits for palette attributes 922 h1.lim <- c(-360, 360) 923 h2.lim <- c(-360, 360) 924 c1.lim <- c( 0, 100) 925 cmax.lim <- c( 0, 180) 926 c2.lim <- c( 0, 100) 927 l1.lim <- c( 0, 100) 928 l2.lim <- c( 0, 100) 929 p1.lim <- c( 0, 3) 930 p2.lim <- c( 0, 3) 931 n.lim <- c( 1, 50) 932 933 # Set dimensions on palette canvas 934 cvs.width <- 328 # 30 * 10 + 10 + 18 935 cvs.height <- 25 936 937 # Assign additional variables linked to Tk widgets 938 example.var <- tcltk::tclVar() 939 nature.var <- tcltk::tclVar() 940 941 n.scl.var <- tcltk::tclVar(n) 942 n.ent.var <- tcltk::tclVar(n) 943 944 # Setting up tcltk variables and scale elements. 945 for ( key in vars.pal[!vars.pal %in% "type"] ) { 946 eval(parse(text = sprintf("%s.scl.var <- tcltk::tclVar()", key))) 947 eval(parse(text = sprintf("%s.ent.var <- tcltk::tclVar()", key))) 948 } 949 950 # Adding tcltk variables for the color control elements 951 # (checkboxes, radio buttons) with defaults. 952 fixup.var <- tcltk::tclVar(fixup) 953 reverse.var <- tcltk::tclVar(FALSE) 954 desaturation.var <- tcltk::tclVar(FALSE) 955 darkmode.var <- tcltk::tclVar(FALSE) 956 colorblind.var <- tcltk::tclVar(FALSE) 957 colorblind.type.var <- tcltk::tclVar("deutan") 958 959 tt.done.var <- tcltk::tclVar(0) 960 ttreg.done.var <- tcltk::tclVar(0) 961 962 # Open GUI 963 tcltk::tclServiceMode(FALSE) 964 965 tt <- tcltk::tktoplevel() 966 if (!is.null(parent)) { 967 tcltk::tkwm.transient(tt, parent) 968 geo <- unlist(strsplit(as.character(tcltk::tkwm.geometry(parent)), "\\+")) 969 tcltk::tkwm.geometry(tt, paste("+", as.integer(geo[2]) + 25, 970 "+", as.integer(geo[3]) + 25, sep="")) 971 } 972 tcltk::tkwm.resizable(tt, 0, 0) 973 tcltk::tkwm.geometry(tt, "425x745+0+10") 974 tcltk::tktitle(tt) <- "Choose Color Palette" 975 976 # Top file menu 977 top.menu <- tcltk::tkmenu(tt, tearoff = 0) 978 menu.file <- tcltk::tkmenu(tt, tearoff = 0) 979 tcltk::tkadd(top.menu, "cascade", label = "File", menu = menu.file, underline = 0) 980 tcltk::tkadd(top.menu, "command", label = "Register", 981 command = RegisterPalette, underline = 0) 982 983 tcltk::tkadd(menu.file, "command", label = "Open palette", accelerator = "Ctrl+O", 984 command = OpenPaletteFromFile) 985 tcltk::tkadd(menu.file, "command", label = "Save palette as", 986 accelerator = "Shift+Ctrl+S", command = SavePaletteToFile) 987 988 menu.file.colors <- tcltk::tkmenu(tt, tearoff=0) 989 tcltk::tkadd(menu.file.colors, "command", label="HEX", 990 command=function() SaveColorsToFile("HEX")) 991 tcltk::tkadd(menu.file.colors, "command", label="sRGB", 992 command=function() SaveColorsToFile("sRGB")) 993 tcltk::tkadd(menu.file.colors, "command", label="HSV", 994 command=function() SaveColorsToFile("HSV")) 995 tcltk::tkadd(menu.file.colors, "command", label="HCL", 996 command=function() SaveColorsToFile("HCL")) 997 tcltk::tkadd(menu.file.colors, "command", label="CMYK", 998 command=function() SaveColorsToFile("CMYK")) 999 tcltk::tkadd(menu.file, "cascade", label="Save colors as", menu=menu.file.colors) 1000 1001 tcltk::tkconfigure(tt, menu=top.menu) 1002 1003 # Frame 0, ok and cancel buttons 1004 frame0 <- tcltk::ttkframe(tt, relief="flat") 1005 frame0.but.3 <- tcltk::ttkbutton(frame0, width=12, text="OK", command=SavePalette) 1006 frame0.but.4 <- tcltk::ttkbutton(frame0, width=12, text="Cancel", 1007 command=function() { 1008 pal.rtn <<- NULL 1009 tcltk::tclvalue(tt.done.var) <- 1 1010 }) 1011 tcltk::tkgrid("x", frame0.but.3, frame0.but.4, pady=c(10, 10)) 1012 tcltk::tkgrid.configure(frame0.but.3, sticky="e") 1013 tcltk::tkgrid.configure(frame0.but.4, sticky="w", padx=c(4, 10)) 1014 tcltk::tkgrid.columnconfigure(frame0, 0, weight=1) 1015 1016 tcltk::tkpack(frame0, fill="x", side="bottom", anchor="e") 1017 1018 # Frame 1, choose nature of data 1019 frame1 <- tcltk::ttkframe(tt, relief = "flat") 1020 frame1.lab.1 <- tcltk::ttklabel(frame1, text = "Type of palette: ") 1021 frame1.box.2 <- tcltk::ttkcombobox(frame1, state = "readonly", textvariable = nature.var, 1022 values=c("Basic: Qualitative", 1023 "Basic: Sequential (single-hue)", 1024 "Basic: Sequential (multi-hue)", 1025 "Basic: Diverging", 1026 "Advanced: Sequential (single-hue)", 1027 "Advanced: Sequential (multi-hue)", 1028 "Advanced: Diverging")) 1029 1030 tcltk::tkgrid(frame1.lab.1, frame1.box.2, pady=c(10, 0)) 1031 tcltk::tkgrid.configure(frame1.lab.1, padx=c(10, 2)) 1032 tcltk::tkgrid.configure(frame1.box.2, padx=c(0, 10), sticky="we") 1033 1034 tcltk::tkgrid.columnconfigure(frame1, 1, weight=1) 1035 1036 tcltk::tkpack(frame1, fill="x") 1037 1038 # Frame 2, default color schemes 1039 frame2 <- tcltk::ttklabelframe(tt, relief = "flat", borderwidth = 5, padding = 5, 1040 text = "Default color schemes") 1041 frame2.cvs <- tcltk::tkcanvas(frame2, relief="flat", width = 310, height = 70, 1042 background = "white", confine = TRUE, closeenough = 0, 1043 borderwidth = 0, highlightthickness = 0) 1044 tcltk::tkgrid(frame2.cvs, sticky="we") 1045 tcltk::tkgrid.columnconfigure(frame2, 0, weight=1) 1046 tcltk::tkpack(frame2, fill="x", padx=10, pady=10) 1047 1048 # Frame 3, color description 1049 txt <- "Palette description: Hue, Chroma, Luminance, Power" 1050 frame3 <- tcltk::ttklabelframe(tt, relief="flat", borderwidth=5, padding=5, text=txt) 1051 1052 # Appending labels, tcltk grid and add variables. 1053 # This vector will be used in several places to set values 1054 # and/or enable/disable the elements. 1055 slider_elements <- c("h1", "h2", "c1", "cmax", "c2", "l1", "l2", "p1", "p2", "n") 1056 1057 # Setting up the GUI elements (combination of label, slider, and text output) 1058 for ( i in seq_along(slider_elements) ) { 1059 # Name of the current slider element 1060 key = slider_elements[i] 1061 1062 # Command to create the slider label 1063 cmd_label <- sprintf("frame3.lab.%1$d.1 <- tcltk::ttklabel(frame3, text=\"%2$s\", width=5)", 1064 i, toupper(key)) 1065 1066 # Command to create the slider 1067 # For p1/p2: numeric(...), for all others: round(numeric(...)) 1068 if ( grepl("^p", key) ) { 1069 scl_fun <- "as.numeric(...)" 1070 } else { 1071 scl_fun <- "round(as.numeric(...))" 1072 } 1073 cmd_slider <- sprintf(paste("frame3.scl.%1$d.2 <- tcltk::tkwidget(frame3,", 1074 "\"ttk::scale\", from = %3$s.lim[1L], to = %3$s.lim[2L],", 1075 "orient = \"horizontal\", value = %3$s, variable = %3$s.scl.var,", 1076 "command = function(...) {", 1077 " ScaleChange(x = %2$s, v=\"%3$s\", x.ent.var = %3$s.ent.var)", 1078 "})"), i, scl_fun, key) 1079 1080 # Command to create the text output 1081 cmd_text <- sprintf(paste("frame3.ent.%1$d.3 <- tcltk::ttkentry(frame3,", 1082 "textvariable=%2$s.ent.var, width = 4)"), i, key) 1083 1084 # Execute the commands 1085 eval(parse(text = cmd_label)) 1086 eval(parse(text = cmd_slider)) 1087 eval(parse(text = cmd_text)) 1088 1089 1090 # Place all sliders (except n) on frame3 1091 if ( ! key == "n" ) { 1092 cmd <- sprintf(paste("tcltk::tkgrid(frame3.lab.%1$d.1, frame3.scl.%1$d.2,", 1093 "frame3.ent.%1$d.3, pady=c(0, 5))"), i) 1094 eval(parse(text = cmd)) 1095 } 1096 } 1097 1098 tcltk::tkgrid.configure(frame3.scl.1.2, frame3.scl.2.2, frame3.scl.3.2, 1099 frame3.scl.4.2, frame3.scl.5.2, frame3.scl.6.2, 1100 frame3.scl.7.2, frame3.scl.8.2, frame3.scl.9.2, 1101 sticky="we", padx=c(4, 10)) 1102 1103 tcltk::tkgrid.columnconfigure(frame3, 1, weight=1) 1104 1105 tcltk::tkpack(frame3, fill="x", padx=10, pady=0) 1106 1107 # Frame 4, color palette fixup 1108 frame4 <- tcltk::ttkframe(tt, relief="flat") 1109 txt <- "Correct all colors to valid RGB color model values" 1110 frame4.chk.1 <- tcltk::ttkcheckbutton(frame4, text=txt, variable=fixup.var, 1111 command=function() { 1112 fixup <<- as.integer(tcltk::tclvalue(fixup.var)) 1113 DrawPalette(is.n = TRUE) 1114 }) 1115 tcltk::tkgrid.configure(frame4.chk.1, padx=c(12, 0), pady=c(2, 0)) 1116 tcltk::tkpack(frame4, fill="x") 1117 1118 # Frame 5, number of colors in palette 1119 txt <- "Number of colors in palette" 1120 frame5 <- tcltk::ttklabelframe(tt, relief="flat", borderwidth=5, padding=5, text=txt) 1121 1122 frame5.lab.1 <- tcltk::ttklabel(frame5, text="n", width=2) 1123 frame5.ent.3 <- tcltk::ttkentry(frame5, textvariable=n.ent.var, width=4) 1124 frame5.scl.2 <- tcltk::tkwidget(frame5, "ttk::scale", from=n.lim[1], to=n.lim[2], 1125 orient="horizontal", value=n, variable=n.scl.var, 1126 command=function(...) { 1127 ScaleChange(x=round(as.numeric(...)), v="n", 1128 x.ent.var=n.ent.var) 1129 }) 1130 1131 tcltk::tkgrid(frame5.lab.1, frame5.scl.2, frame5.ent.3) 1132 tcltk::tkgrid.configure(frame5.scl.2, sticky = "we", padx = c(4, 10)) 1133 tcltk::tkgrid.columnconfigure(frame5, 1, weight = 1) 1134 1135 tcltk::tkpack(frame5, fill = "x", padx = 10, pady = 10) 1136 1137 # Frame 6, example plots and reverse colors 1138 frame6 <- tcltk::ttklabelframe(tt, relief = "flat", borderwidth = 5, padding = 5, 1139 text = "Show example") 1140 frame6.lab.1 <- tcltk::ttklabel(frame6, text="Plot type") 1141 frame6.box.2 <- tcltk::ttkcombobox(frame6, state="readonly", 1142 textvariable = example.var, 1143 values = example.plots) 1144 frame6.chk.3 <- tcltk::ttkcheckbutton(frame6, text = "Reverse colors", 1145 variable = reverse.var, 1146 command = function() { 1147 reverse <<- as.logical(as.integer(tcltk::tclvalue(reverse.var))) 1148 DrawPalette(is.n = TRUE) 1149 }) 1150 tcltk::tkgrid(frame6.lab.1, frame6.box.2, frame6.chk.3) 1151 tcltk::tkgrid.configure(frame6.box.2, padx = c(2, 10), sticky = "we") 1152 tcltk::tkgrid.columnconfigure(frame6, 1, weight = 1) 1153 tcltk::tkpack(frame6, fill = "x", padx = 10, pady = 0) 1154 1155 # Frame 7, color palette and robustness checks 1156 frame7 <- tcltk::ttkframe(tt, relief="flat") 1157 frame7.cvs <- tcltk::tkcanvas(frame7, relief="flat", 1158 width=cvs.width + 1, height=cvs.height + 1, 1159 background = "black", confine = TRUE, closeenough = 0, 1160 borderwidth = 0, highlightthickness = 0) 1161 tcltk::tkgrid(frame7.cvs, padx=10, pady=c(12,10)) 1162 1163 frame7.chk.1 <- tcltk::ttkcheckbutton(frame7, text="Desaturation", 1164 variable=desaturation.var, 1165 command=function() DrawPalette(is.n = TRUE)) 1166 frame7.chk.2 <- tcltk::ttkcheckbutton(frame7, text="Dark mode", 1167 variable=darkmode.var, 1168 command=function() ActivateDarkmode()) 1169 1170 tcltk::tkgrid(frame7.chk.1, frame7.chk.2, "x", 1171 pady = c(2, 0), sticky = "w") 1172 tcltk::tkgrid.configure(frame7.chk.2, padx = c(7, 0)) 1173 tcltk::tkgrid.configure(frame7.cvs, columnspan=5) 1174 tcltk::tkgrid.columnconfigure(frame7, 4, weight = 1) 1175 tcltk::tkgrid.configure(frame7.chk.1, padx=c(10, 0)) 1176 tcltk::tkpack(frame7, fill="x") 1177 1178 1179 # Frame 8, cvd options 1180 frame8 <- tcltk::ttkframe(tt, relief="flat") 1181 frame8.chk.1 <- tcltk::ttkcheckbutton(frame8, text = "Color blindness:", 1182 variable = colorblind.var, 1183 command = function() DrawPalette(is.n = TRUE)) 1184 frame8.rb.2 <- tcltk::ttkradiobutton(frame8, variable = colorblind.type.var, 1185 value = "deutan", text = "deutan", 1186 command = function() DrawPalette(is.n = TRUE)) 1187 frame8.rb.3 <- tcltk::ttkradiobutton(frame8, variable = colorblind.type.var, 1188 value = "protan", text = "protan", 1189 command = function() DrawPalette(is.n = TRUE)) 1190 frame8.rb.4 <- tcltk::ttkradiobutton(frame8, variable = colorblind.type.var, 1191 value = "tritan", text = "tritan", 1192 command = function() DrawPalette(is.n = TRUE)) 1193 1194 tcltk::tkgrid(frame8.chk.1, frame8.rb.2, frame8.rb.3, frame8.rb.4, 1195 pady = c(2, 0), sticky = "w") 1196 tcltk::tkgrid.configure(frame8.rb.2, padx = c(7, 0)) 1197 tcltk::tkgrid.columnconfigure(frame8, 4, weight = 1) 1198 tcltk::tkgrid.configure(frame8.chk.1, padx=c(10, 0)) 1199 tcltk::tkpack(frame8, fill="x") 1200 1201 # Initial commands 1202 pal_args <- ConvertPaletteToAttributes(pal) 1203 # Assign attributes to widget, also enables/disables the sliders 1204 AssignAttributesToWidgets(pal_args) 1205 UpdateDataType(init = TRUE) 1206 1207 # Bind events 1208 tcltk::tclServiceMode(TRUE) 1209 1210 tcltk::tkbind(tt, "<Control-o>", OpenPaletteFromFile) 1211 tcltk::tkbind(tt, "<Shift-Control-S>", SavePaletteToFile) 1212 tcltk::tkbind(tt, "<Control-r>", RegisterPalette) 1213 1214 UpdateDataTypeInit <- function() UpdateDataType(init = TRUE) 1215 tcltk::tkbind(frame1.box.2, "<<ComboboxSelected>>", UpdateDataTypeInit) 1216 tcltk::tkbind(frame6.box.2, "<<ComboboxSelected>>", ShowExample) 1217 1218 tcltk::tkbind(frame2.cvs, "<ButtonPress>", function(x, y) SelectDefaultPalette(x, y)) 1219 1220 tcltk::tkbind(frame3.ent.1.3, "<KeyRelease>", 1221 function() EntryChange("h1", h1.lim, h1.ent.var, h1.scl.var)) 1222 tcltk::tkbind(frame3.ent.2.3, "<KeyRelease>", 1223 function() EntryChange("h2", h2.lim, h2.ent.var, h2.scl.var)) 1224 tcltk::tkbind(frame3.ent.3.3, "<KeyRelease>", 1225 function() EntryChange("c1", c1.lim, c1.ent.var, c1.scl.var)) 1226 tcltk::tkbind(frame3.ent.4.3, "<KeyRelease>", 1227 function() EntryChange("cmax", cmax.lim, cmax.ent.var, cmax.scl.var)) 1228 tcltk::tkbind(frame3.ent.5.3, "<KeyRelease>", 1229 function() EntryChange("c2", c2.lim, c2.ent.var, c2.scl.var)) 1230 tcltk::tkbind(frame3.ent.6.3, "<KeyRelease>", 1231 function() EntryChange("l1", l1.lim, l1.ent.var, l1.scl.var)) 1232 tcltk::tkbind(frame3.ent.7.3, "<KeyRelease>", 1233 function() EntryChange("l2", l2.lim, l2.ent.var, l2.scl.var)) 1234 tcltk::tkbind(frame3.ent.8.3, "<KeyRelease>", 1235 function() EntryChange("p1", p1.lim, p1.ent.var, p1.scl.var)) 1236 tcltk::tkbind(frame3.ent.9.3, "<KeyRelease>", 1237 function() EntryChange("p2", p2.lim, p2.ent.var, p2.scl.var)) 1238 1239 tcltk::tkbind(frame5.ent.3, "<KeyRelease>", 1240 function() EntryChange("n", n.lim, n.ent.var, n.scl.var)) 1241 1242 tcltk::tkbind(tt, "<Destroy>", function() { 1243 tcltk::tclvalue(tt.done.var) <- 1; 1244 tcltk::tclvalue(ttreg.done.var) <- 1 }); 1245 1246 # GUI control 1247 tcltk::tkfocus(tt) 1248 tcltk::tkgrab(tt) 1249 1250 tcltk::tkwait.variable(tt.done.var) 1251 1252 tcltk::tclServiceMode(FALSE) 1253 tcltk::tkgrab.release(tt) 1254 tcltk::tkdestroy(tt) 1255 tcltk::tclServiceMode(TRUE) 1256 1257 if (dev.example %in% dev.list()) dev.off(which = dev.example) 1258 1259 invisible(pal.rtn) 1260} 1261 1262 1263# Setting global variables to avoid notes during R CMD check 1264utils::globalVariables(c("type" , "h1" , "h2" , "c1" , "l1" , "reverse" , "cmax" , 1265 "c2" , "l2" , "p1", "p2")) 1266 1267 1268 1269# Get color palette as function of n 1270# For testing: 1271# args <- list(type = "sequential (single hue)", 1272# h1 = 0, h2 = 120, 1273# c1 = 10, c2 = 80, 1274# l1 = 90, l2 = 10, 1275# fixup = TRUE, p1 = 1, p2 = 1, 1276# reverse = FALSE, cmax = 50, register = "") 1277# pal <- do.call(colorspace:::GetPalette, args) 1278# colorspace::swatchplot(pal(10)) 1279GetPalette <- function(...) { #type, h1, h2, c1, c2, l1, l2, p1, p2, fixup, reverse, cmax, register) { 1280 1281 # Input arguments to list and make fixup logical 1282 arg <- list(...) 1283 arg$fixup <- as.logical(arg$fixup) 1284 1285 # Qualitative color palettes 1286 if (grepl("^(qual|.*[Qq]ualitative)", arg$type)) { 1287 f <- qualitative_hcl 1288 formals(f) <- eval(substitute(alist(n =, h = hh, c = d1, l = d2, 1289 fixup = d3, gamma = NULL, alpha = 1, 1290 palette = NULL, rev = d4, 1291 register = d5, ... =, 1292 h1=, h2=, c1=, l1=, cmax=), 1293 list(hh = c(arg$h1, arg$h2), 1294 d1 = arg$c1, 1295 d2 = arg$l1, 1296 d3 = arg$fixup, 1297 d4 = arg$reverse, 1298 d5 = arg$register))) 1299 1300 # Sequential single-hue palettes 1301 } else if (grepl("^(seqs|.*[Ss]equential.*single)", arg$type)) { 1302 f <- sequential_hcl 1303 formals(f) <- eval(substitute(alist(n =, h = d1, c = d2, l = d3, power = d4, 1304 gamma = NULL, fixup = d5, alpha = 1, 1305 palette = NULL, rev = d6, register = d7, ... =, 1306 h1 =, h2 =, c1 =, c2 =, l1 =, l2 =, p1 =, p2 =, cmax =, c. =), 1307 list(d1 = arg$h1, 1308 d2 = c(arg$c1, arg$cmax, arg$c2), 1309 d3 = c(arg$l1, arg$l2), 1310 d4 = arg$p1, 1311 d5 = arg$fixup, 1312 d6 = arg$reverse, 1313 d7 = arg$register))) 1314 1315 # Sequential multi-hue palettes 1316 } else if (grepl("^(seqm|.*[Ss]equential.*multi)", arg$type)) { 1317 f <- sequential_hcl 1318 formals(f) <- eval(substitute(alist(n =, h = d1, c = d2, l = d3, power = d4, 1319 gamma = NULL, fixup = d5, alpha = 1, 1320 palette = NULL, rev = d6, register = d7, ... =, 1321 h1 =, h2 =, c1 =, c2 =, l1 =, l2 =, p1 =, p2 =, cmax =, c. =), 1322 list(d1 = c(arg$h1, arg$h2), 1323 d2 = c(arg$c1, arg$cmax, arg$c2), 1324 d3 = c(arg$l1, arg$l2), 1325 d4 = c(arg$p1, arg$p2), 1326 d5 = arg$fixup, 1327 d6 = arg$reverse, 1328 d7 = arg$register))) 1329 1330 # Diverging color palettes 1331 } else if (grepl("^(dive|.*[Dd]iverging)", arg$type)) { 1332 f <- diverging_hcl 1333 arg_names <- names(arg[!is.na(arg)]) 1334 if ( all(c("p1", "p2") %in% arg_names) ) power <- c(arg$p1, arg$p2) else power <- arg$p1 1335 if ( all(c("c1", "cmax") %in% arg_names) ) chroma <- c(arg$c1, arg$cmax) else chroma <- arg$c1 1336 formals(f) <- eval(substitute(alist(n =, h=d1, c = d2, l = d3, power = d4, 1337 gamma = NULL, fixup = d5, alpha = 1, 1338 palette = NULL, rev = d6, register = d7, ... =, 1339 h1 =, h2 =, c1 =, l1 =, l2 =, p1 =, p2 =, cmax = d8), 1340 list(d1 = c(arg$h1, arg$h2), 1341 d2 = chroma, 1342 d3 = c(arg$l1, arg$l2), 1343 d4 = power, 1344 d5 = arg$fixup, 1345 d6 = arg$reverse, 1346 d7 = arg$register, 1347 d8 = arg$cmas))) 1348 } 1349 f 1350} 1351 1352