настраиваемая цветовая палитра, извлечение функции из колористического пространства :: choose_palette () - PullRequest
Новая
       3

настраиваемая цветовая палитра, извлечение функции из колористического пространства :: choose_palette ()

3 голосов
/ 30 апреля 2020

Мне нужно реализовать собственную цветовую палитру (мне не нравятся доступные пресеты). Я нахожу полезную функцию из пакета colorspace, которая позволяет создавать палитру, используя простой GUI. Функция choose_palette() Используя GUI, можно выбрать цвета, яркость и т. Д. c ... Что я хочу сделать, это получить функцию, которая генерирует мою собственную палитру, как показано ниже: 

library(colorspace)

#I create my custom palette using the GUI

my_custom_palette<-choose_palette()
#play with the parameters and save

#now I have the function my_custom_palette
view(my_custom_palette)

function (n, h = c(255, 158), c = c(50, 80), l = c(20, 97), 
  power = c(2.04778156996587, 0.767918088737201), gamma = NULL, 
  fixup = TRUE, alpha = 1, palette = NULL, rev = FALSE, register = NULL, 
  ..., h1, h2, c1, l1, l2, p1, p2, cmax = NULL) 
{
  if (!is.null(gamma)) 
    warning("'gamma' is deprecated and has no effect")
  if (n < 1L) 
    return(character(0L))
  if (is.character(h)) 
    palette <- h
  pals <- if (!is.null(palette)) {
    as.matrix(hcl_palettes(type = "Diverging", palette = palette)[, 
      2L:11L])[1L, ]
  }
  else {
    structure(c(rep_len(h, 2L), c(c[1L], NA), rep_len(l, 
      2L), if (length(power) < 2L) c(power, NA) else rep_len(power, 
      2L), if (length(c) > 1L) c[2L] else NA, 1), .Names = vars.pal)
  }
  if (!missing(h) && !is.character(h)) {
    h <- rep_len(h, 2L)
    pals["h1"] <- h[1L]
    pals["h2"] <- h[2L]
  }
  if (!missing(c)) {
    pals["c1"] <- c[1L]
    if (length(c) > 1L) 
      pals["cmax"] <- c[2L]
  }
  if (!missing(l)) {
    l <- rep_len(l, 2L)
    pals["l1"] <- l[1L]
    pals["l2"] <- l[2L]
  }
  if (!missing(power)) {
    power <- if (length(power) < 2L) 
      c(power, NA)
    else rep_len(power, 2L)
    pals["p1"] <- power[1L]
    pals["p2"] <- power[2L]
  }
  if (!missing(fixup)) 
    pals["fixup"] <- as.logical(fixup)
  if (!missing(h1)) 
    pals["h1"] <- h1
  if (!missing(h2)) 
    pals["h2"] <- h2
  if (!missing(c1)) 
    pals["c1"] <- c1
  if (!missing(l1)) 
    pals["l1"] <- l1
  if (!missing(l2)) 
    pals["l2"] <- l2
  if (!missing(p1)) 
    pals["p1"] <- p1
  if (!missing(p2)) 
    pals["p2"] <- p2
  if (!missing(cmax)) 
    pals["cmax"] <- cmax
  pals["c2"] <- NA
  if (is.character(register) && nchar(register) > 0L) {
    add_hcl_pals(palette = register, type = "Diverging", 
      parameters = pals)
    register <- TRUE
  }
  else {
    register <- FALSE
  }
  if (is.na(pals["p2"])) 
    pals["p2"] <- pals["p1"]
  n2 <- ceiling(n/2)
  rval <- seq.int(1, by = -2/(n - 1), length.out = n2)
  rval <- c(seqhcl(rval, pals["h1"], pals["h1"], pals["c1"], 
    0, pals["l1"], pals["l2"], pals["p1"], pals["p2"], pals["cmax"], 
    as.logical(pals["fixup"]), ...), rev(seqhcl(rval, pals["h2"], 
    pals["h2"], pals["c1"], 0, pals["l1"], pals["l2"], pals["p1"], 
    pals["p2"], pals["cmax"], as.logical(pals["fixup"]), 
    ...)))
  if (floor(n/2) < n2) 
    rval <- rval[-n2]
  if (!missing(alpha)) {
    alpha <- pmax(pmin(alpha, 1), 0)
    alpha <- format(as.hexmode(round(alpha * 255 + 1e-04)), 
      width = 2L, upper.case = TRUE)
    rval <- ifelse(is.na(rval), NA, paste(rval, alpha, sep = ""))
  }
  if (rev) 
    rval <- rev(rval)
  if (register) 
    invisible(rval)
  else return(rval)
}

Теперь я предполагаю, что с помощью кода функции я могу создать палитру в блестящем приложении без запуска GUI с choose_palette ()

Итак, я набираю 

my_custom_palette_2<-function (n, h = c(255, 158), c = c(50, 80), l = c(20, 97), 
  power = c(2.04778156996587, 0.767918088737201), gamma = NULL, 
  fixup = TRUE, alpha = 1, palette = NULL, rev = FALSE, register = NULL, 
  ..., h1, h2, c1, l1, l2, p1, p2, cmax = NULL) 
{
  if (!is.null(gamma)) 
    warning("'gamma' is deprecated and has no effect")
  if (n < 1L) 
    return(character(0L))
  if (is.character(h)) 
    palette <- h
  pals <- if (!is.null(palette)) {
    as.matrix(hcl_palettes(type = "Diverging", palette = palette)[, 
      2L:11L])[1L, ]
  }
  else {
    structure(c(rep_len(h, 2L), c(c[1L], NA), rep_len(l, 
      2L), if (length(power) < 2L) c(power, NA) else rep_len(power, 
      2L), if (length(c) > 1L) c[2L] else NA, 1), .Names = vars.pal)
  }
  if (!missing(h) && !is.character(h)) {
    h <- rep_len(h, 2L)
    pals["h1"] <- h[1L]
    pals["h2"] <- h[2L]
  }
  if (!missing(c)) {
    pals["c1"] <- c[1L]
    if (length(c) > 1L) 
      pals["cmax"] <- c[2L]
  }
  if (!missing(l)) {
    l <- rep_len(l, 2L)
    pals["l1"] <- l[1L]
    pals["l2"] <- l[2L]
  }
  if (!missing(power)) {
    power <- if (length(power) < 2L) 
      c(power, NA)
    else rep_len(power, 2L)
    pals["p1"] <- power[1L]
    pals["p2"] <- power[2L]
  }
  if (!missing(fixup)) 
    pals["fixup"] <- as.logical(fixup)
  if (!missing(h1)) 
    pals["h1"] <- h1
  if (!missing(h2)) 
    pals["h2"] <- h2
  if (!missing(c1)) 
    pals["c1"] <- c1
  if (!missing(l1)) 
    pals["l1"] <- l1
  if (!missing(l2)) 
    pals["l2"] <- l2
  if (!missing(p1)) 
    pals["p1"] <- p1
  if (!missing(p2)) 
    pals["p2"] <- p2
  if (!missing(cmax)) 
    pals["cmax"] <- cmax
  pals["c2"] <- NA
  if (is.character(register) && nchar(register) > 0L) {
    add_hcl_pals(palette = register, type = "Diverging", 
      parameters = pals)
    register <- TRUE
  }
  else {
    register <- FALSE
  }
  if (is.na(pals["p2"])) 
    pals["p2"] <- pals["p1"]
  n2 <- ceiling(n/2)
  rval <- seq.int(1, by = -2/(n - 1), length.out = n2)
  rval <- c(seqhcl(rval, pals["h1"], pals["h1"], pals["c1"], 
    0, pals["l1"], pals["l2"], pals["p1"], pals["p2"], pals["cmax"], 
    as.logical(pals["fixup"]), ...), rev(seqhcl(rval, pals["h2"], 
    pals["h2"], pals["c1"], 0, pals["l1"], pals["l2"], pals["p1"], 
    pals["p2"], pals["cmax"], as.logical(pals["fixup"]), 
    ...)))
  if (floor(n/2) < n2) 
    rval <- rval[-n2]
  if (!missing(alpha)) {
    alpha <- pmax(pmin(alpha, 1), 0)
    alpha <- format(as.hexmode(round(alpha * 255 + 1e-04)), 
      width = 2L, upper.case = TRUE)
    rval <- ifelse(is.na(rval), NA, paste(rval, alpha, sep = ""))
  }
  if (rev) 
    rval <- rev(rval)
  if (register) 
    invisible(rval)
  else return(rval)
}

Для 2-х палитр код тот же, первый, созданный с помощью choose_palette (), работает, второй не: 

my_custom_palette(5)
[1] "#002F70" "#717B99" "#F6F6F6" "#518673" "#00421A"

my_custom_palette_2(5)
Error in my_custom_palette_2(5) : 
 promise already under evaluation: recursive default argument reference or earlier problems?

Что не так? Заранее спасибо

Ответы [ 2 ]

1 голос
/ 05 мая 2020

Я решил с помощью функции, предложенной @Achim Zeileis, следующим образом: с помощью всех параметров, выбранных из GUI Я создал эту функцию 

`custom_color_palette<-function(n){colorspace::diverge_hcl(n, gamma = NULL,fixup = TRUE, alpha = 1, palette = NULL, rev = FALSE, register = NULL, h1=255, h2=119, c1=53,l1=33,l2=82,p1=.01,p2=1.3, cmax = 93)}
`

Таким образом, я могу вспомнить ее на графике , указав нужное количество разных цветов: 

plot_ly(x=x,y=y,color=group,colors=custom_color_palette(5))
1 голос
/ 04 мая 2020

Виновником является h = c(255, 158), c = c(50, 80) в определении функции. Это работает с семантикой NAMESPACE внутри пакета colorspace, поскольку ясно, что функция c(), используемая для определения h, равна base::c(). В вашем пользовательском коде это неясно и приводит к рекурсии, потому что R пытается сначала определить значение аргумента c.

Но есть более простое решение вашей проблемы. Используя выбранные параметры, вы можете просто вычислить цвета из палитры с помощью 

diverging_hcl(5, h = c(255, 158), c = c(50, 80),
  l = c(20, 97), power = c(2.05, 0.77))
## [1] "#002F70" "#717B99" "#F6F6F6" "#528673" "#00421A"

В качестве альтернативы, вы также можете зарегистрировать палитру с именем и использовать ее впоследствии: 

diverging_hcl(5, h = c(255, 158), c = c(50, 80),
  l = c(20, 97), power = c(2.05, 0.77), register = "mypal")
diverging_hcl(5, "mypal")
## [1] "#002F70" "#717B99" "#F6F6F6" "#528673" "#00421A"

Вы Вы также можете поместить последний вызов в ваш .Rprofile, чтобы палитра была доступна при каждом запуске R.

Опция через регистрацию также явно указана в блестящей версии hclwizard() / * 1020. * на вкладке> Экспорт> Регистрация справа. В версии Tcl / Tk вы также можете зарегистрировать палитру на вкладке «Регистрация» в верхней части.

Обратите внимание, что в любом случае результирующая палитра может быть дополнительно настроена, например, 

diverging_hcl(5, "mypal", c = 0)
## [1] "#303030" "#6B7BA6" "#F6F6F6" "#338A6F" "#303030"
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...